VBA For Each循环无法遍历Outlook文件夹全部邮件的解决咨询

原代码无法一次性移完所有邮件，核心问题在于Outlook的Items集合是动态集合：当你用Move方法移除邮件时，集合的元素会实时调整，而For Each循环是基于初始的集合快照遍历的，这会导致循环过程中跳过部分元素，必须多次运行才能处理完所有邮件。

下面提供两种可靠的修改方案：

方案一：反向索引循环 #

从最后一封邮件开始往前处理，这样即使前面的邮件被移走，后面的索引不会因为集合变化而错位，确保每一封邮件都被处理：

Sub TestLoop()
    
    Dim olApp       As Outlook.Application
    Dim objNS       As Outlook.NameSpace
    Dim olFolder    As Outlook.MAPIFolder
    Dim inmsg       As Object
    Dim i As Integer
    
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set olFolder = objNS.Folders("x@y.com").Folders("Test")
    Set myDestFolder1 = objNS.Folders("x@y.com").Folders("Test1")
    
    ' 从最后一个元素开始反向遍历
    For i = olFolder.Items.Count To 1 Step -1
        Set inmsg = olFolder.Items(i)
        inmsg.Move myDestFolder1
    Next i
    
End Sub

方案二：循环处理第一封邮件直至为空 #

直接循环处理源文件夹的第一封邮件，直到文件夹中没有剩余邮件为止。每次移走第一封后，下一封邮件会自动成为新的第一封，逻辑更直观：

Sub TestLoop()
    
    Dim olApp       As Outlook.Application
    Dim objNS       As Outlook.NameSpace
    Dim olFolder    As Outlook.MAPIFolder
    Dim inmsg       As Object
    
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set olFolder = objNS.Folders("x@y.com").Folders("Test")
    Set myDestFolder1 = objNS.Folders("x@y.com").Folders("Test1")
    
    ' 持续处理直到源文件夹无邮件
    Do While olFolder.Items.Count > 0
        Set inmsg = olFolder.Items(1)
        inmsg.Move myDestFolder1
    Loop
    
End Sub

两种方案都能一次性完成所有邮件的转移，你可以根据自己的习惯选择使用。

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