遍历Outlook文件夹处理邮件时遗漏一封的技术求助

当用For Each遍历Outlook邮件集合时，每执行一次OlMail.Move操作，当前邮件就会从原文件夹的邮件集合中被移除。这会导致集合的内部迭代器错位：比如原集合是[邮件1,邮件2,邮件3]，处理完邮件1并移动后，集合变为[邮件2,邮件3]，迭代器会直接跳到原位置2的元素（即现在的邮件3），跳过了原本的邮件2，最终出现遗漏。

Dim OlApp                          
Dim OlMail                         
Dim OlItems                       
Dim Olfolder                       
Dim OlSubfolder                    
Dim MyNameSpace
Dim J As Integer
Dim strFolder As String
Dim MyFileName() As String
Dim EmailCount As Integer
Dim X As Integer
Dim i As Integer '新增循环索引变量

Set OlApp = GetObject(, "Outlook.Application")
    
If Err.Number = 429 Then
    Set OlApp = CreateObject("Outlook.Application")
End If

strFolder = "C:\Temp\MarketPay\"
    
Set MyNameSpace = Application.GetNamespace("MAPI")

'拆分文件夹与邮件集合的获取，代码更清晰
Set Olfolder = MyNameSpace.Folders("Efficiency Tools").Folders("Inbox").Folders("HomePay")
Set OlItems = Olfolder.Items

Set OlSubfolder = MyNameSpace.Folders("Efficiency Tools").Folders("Inbox").Folders("HomePay").Folders("Completed")

EmailCount = OlItems.Count
X = 1

'从最后一封邮件往前遍历，避免移动邮件导致的集合错位
For i = EmailCount To 1 Step -1
    Set OlMail = OlItems(i)
    
    DoEvents
    
    For J = 1 To OlMail.Attachments.Count
        ReDim Preserve MyFileName(1 To X)
        '存储附件文件名而非Attachment对象
        MyFileName(X) = OlMail.Attachments(J).FileName
        
        '移除重复的保存操作，一次即可完成附件存储
        OlMail.Attachments(J).SaveAsFile strFolder & OlMail.Attachments(J).FileName
        
        X = X + 1
    Next J
    
    OlMail.Move OlSubfolder
Next i

• 移除了strFolder不必要的空值赋值，直接指定目标路径
• 修正了MyFileName数组的存储内容：原代码存的是Attachment对象，现在改为存附件文件名，符合数组命名的预期
• 删除了重复的SaveAsFile调用，避免重复保存同一附件
• 拆分了文件夹与邮件集合的获取逻辑，提升代码可读性

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