Outlook VBA宏问题：如何移动收件箱最旧而非最新邮件

问题背景 #

我给Outlook按钮绑定了一个宏，功能是让客服操作时：

• 自动移动所有标记了对应用户名类别的邮件到指定文件夹
• 告知已移动邮件数量，再询问是否需要额外邮件
• 额外邮件要求拉取最旧的未分类邮件，但实际拉取的是最新的，调整Sort参数的True/False也没解决问题。

原代码 #

Sub MoveAndCategorizeEmails()

    ' Declare variables
    Dim olNamespace As Outlook.NameSpace
    Dim olInbox As Outlook.MAPIFolder
    Dim olMSREmails As Outlook.MAPIFolder
    Dim olMail As Outlook.MailItem
    Dim olItems As Outlook.Items
    Dim olFolder As Outlook.MAPIFolder
    Dim i As Integer
    Dim movedCount As Integer
    Dim additionalEmails As Integer
    Dim userResponse As String
    Dim categoryName As String
    Dim additionalResponse As String

    On Error GoTo ErrorHandler

    ' Set the category name (customize this for each user)
    categoryName = "XXXXXX" ' Replace with your actual category name

    ' Get the namespace (MAPI) and the shared inbox folder
    Set olNamespace = Application.GetNamespace("MAPI")
    Set olInbox = olNamespace.Folders("CUSTOMERSERVICES").Folders("Inbox") ' Update this if the shared inbox name is different
    Set olMSREmails = olNamespace.Folders("CUSTOMERSERVICES").Folders("CSR Emails") ' Ensure this folder exists
    Set olItems = olInbox.Items

    ' Sort items by received date in ascending order (oldest first)
    olItems.Sort "[ReceivedTime]", True

    ' Initialize counters
    movedCount = 0

    ' Loop through the items in the inbox and move categorized emails
    For i = olItems.Count To 1 Step -1
        If TypeOf olItems(i) Is MailItem Then
            Set olMail = olItems(i)
            ' Check if the email is categorized with the specified name
            If olMail.Categories = categoryName Then
                ' Move the email to the corresponding folder
                Set olFolder = olMSREmails.Folders(categoryName) ' Ensure a folder with the category name exists under "MSR Emails"
                olMail.Move olFolder
                movedCount = movedCount + 1
            End If
        End If
    Next i

    ' Prompt the user for the number of additional emails to categorize and move
    additionalResponse = InputBox("A total of " & movedCount & " emails were moved to your folder. How many additional emails do you want to categorize and move?", "Additional Email Request")
    If Not IsNumeric(additionalResponse) Or additionalResponse <= 0 Then
        MsgBox "Please enter a valid number."
        Exit Sub
    End If
    additionalEmails = CInt(additionalResponse)

    ' Categorize and move additional emails if needed
    If additionalEmails > 0 Then
        Dim additionalMovedCount As Integer
        additionalMovedCount = 0 ' Initialize counter for additional emails
        For i = 1 To olItems.Count ' Loop from oldest to newest
            If TypeOf olItems(i) Is MailItem Then
                Set olMail = olItems(i)
                ' Check if the email is not categorized
                If olMail.Categories = "" Then
                    ' Categorize the email with the specified name
                    olMail.Categories = categoryName
                    ' Move the email to the corresponding folder
                    Set olFolder = olMSREmails.Folders(categoryName) ' Ensure a folder with the category name exists under "MSR Emails"
                    olMail.Move olFolder
                    additionalMovedCount = additionalMovedCount + 1
                    ' Exit the loop if the maximum number of additional emails is reached
                    If additionalMovedCount >= additionalEmails Then Exit For
                End If
            End If
        Next i
    End If

    ' Send a summary email
    Dim olApp As Outlook.Application
    Dim olNewMail As Outlook.MailItem
    Set olApp = Outlook.Application
    Set olNewMail = olApp.CreateItem(olMailItem)
    With olNewMail
        .To = "XXXX@XXXXX.com"
        .Subject = "Email Move Summary"
        .Body = "I requested " & additionalEmails & " additional emails to be categorized and moved."
        .Send
    End With

    Exit Sub

ErrorHandler:
    MsgBox "Error " & Err.Number & ": " & Err.Description

End Sub

问题原因 #

第一次循环移动已分类邮件时，olItems集合已经因为邮件被移走而发生了变化，之前的排序状态失效了。处理额外邮件时直接复用这个旧集合，导致排序逻辑不生效，自然拉取的是最新邮件。

解决方法 #

在处理额外邮件前，重新获取收件箱的Items并再次执行排序，确保操作的是最新的、按要求排序的邮件集合。同时，设置邮件类别后要加Save方法，确保类别修改被保存。

完整修改后的代码 #

Sub MoveAndCategorizeEmails()

    ' Declare variables
    Dim olNamespace As Outlook.NameSpace
    Dim olInbox As Outlook.MAPIFolder
    Dim olMSREmails As Outlook.MAPIFolder
    Dim olMail As Outlook.MailItem
    Dim olItems As Outlook.Items
    Dim olFolder As Outlook.MAPIFolder
    Dim i As Integer
    Dim movedCount As Integer
    Dim additionalEmails As Integer
    Dim userResponse As String
    Dim categoryName As String
    Dim additionalResponse As String

    On Error GoTo ErrorHandler

    ' Set the category name (customize this for each user)
    categoryName = "XXXXXX" ' Replace with your actual category name

    ' Get the namespace (MAPI) and the shared inbox folder
    Set olNamespace = Application.GetNamespace("MAPI")
    Set olInbox = olNamespace.Folders("CUSTOMERSERVICES").Folders("Inbox") ' Update this if the shared inbox name is different
    Set olMSREmails = olNamespace.Folders("CUSTOMERSERVICES").Folders("CSR Emails") ' Ensure this folder exists
    Set olItems = olInbox.Items

    ' Sort items by received date in ascending order (oldest first)
    olItems.Sort "[ReceivedTime]", True

    ' Initialize counters
    movedCount = 0

    ' Loop through the items in the inbox and move categorized emails
    For i = olItems.Count To 1 Step -1
        If TypeOf olItems(i) Is MailItem Then
            Set olMail = olItems(i)
            ' Check if the email is categorized with the specified name
            If olMail.Categories = categoryName Then
                ' Move the email to the corresponding folder
                Set olFolder = olMSREmails.Folders(categoryName) ' Ensure a folder with the category name exists under "MSR Emails"
                olMail.Move olFolder
                movedCount = movedCount + 1
            End If
        End If
    Next i

    ' Prompt the user for the number of additional emails to categorize and move
    additionalResponse = InputBox("A total of " & movedCount & " emails were moved to your folder. How many additional emails do you want to categorize and move?", "Additional Email Request")
    If Not IsNumeric(additionalResponse) Or additionalResponse <= 0 Then
        MsgBox "Please enter a valid number."
        Exit Sub
    End If
    additionalEmails = CInt(additionalResponse)

    ' Categorize and move additional emails if needed
    If additionalEmails > 0 Then
        Dim additionalMovedCount As Integer
        additionalMovedCount = 0 ' Initialize counter for additional emails
        ' 重新获取收件箱Items并重新排序
        Set olItems = olInbox.Items
        olItems.Sort "[ReceivedTime]", True
        For i = 1 To olItems.Count
            If TypeOf olItems(i) Is MailItem Then
                Set olMail = olItems(i)
                ' Check if the email is not categorized
                If olMail.Categories = "" Then
                    ' Categorize the email with the specified name
                    olMail.Categories = categoryName
                    olMail.Save ' 保存类别修改
                    ' Move the email to the corresponding folder
                    Set olFolder = olMSREmails.Folders(categoryName) ' Ensure a folder with the category name exists under "MSR Emails"
                    olMail.Move olFolder
                    additionalMovedCount = additionalMovedCount + 1
                    ' Exit the loop if the maximum number of additional emails is reached
                    If additionalMovedCount >= additionalEmails Then Exit For
                End If
            End If
        Next i
    End If

    ' Send a summary email
    Dim olApp As Outlook.Application
    Dim olNewMail As Outlook.MailItem
    Set olApp = Outlook.Application
    Set olNewMail = olApp.CreateItem(olMailItem)
    With olNewMail
        .To = "XXXX@XXXXX.com"
        .Subject = "Email Move Summary"
        .Body = "I requested " & additionalEmails & " additional emails to be categorized and moved."
        .Send
    End With

    Exit Sub

ErrorHandler:
    MsgBox "Error " & Err.Number & ": " & Err.Description

End Sub

内容的提问来源于stack exchange，提问作者Joshua