vba For Each 循环：通过 Outlook 邮箱循环删除项目时会跳过某些项目

For Each loop: Some items get skipped when looping through Outlook mailbox to delete items

提问by buri kuri

I wanted to develop VBA code that:

我想开发这样的 VBA 代码：

1. Loops through all email items in mailbox
2. If there are any type of other items say "Calendar Invitation" skips that item.
3. Finds out the emails with attachments
4. If attached file has ".xml" extension and a specific title in it, saves it to a directory, if not it keeps searching
5. Puts all email includes .xml attachments to "Deleted Items" folder after doing step 4 and deletes all emails in that folder by looping.

1. 遍历邮箱中的所有电子邮件项目
2. 如果有任何类型的其他项目，请说“日历邀请”跳过该项目。
3. 找出带有附件的电子邮件
4. 如果附加文件具有“.xml”扩展名和特定标题，则将其保存到目录中，如果没有，则继续搜索
5. 执行第 4 步后，将所有包含 .xml 附件的电子邮件放入“已删除邮件”文件夹，并通过循环删除该文件夹中的所有电子邮件。

Code works perfect EXCEPT; For example

代码完美运行，除了；例如

1. There are 8 email received with ".xml" file attached to each one of them in your mailbox.
2. run the code
3. you will see only 4 of the 8 items are processed successfully, other 4 remain in their positions.
4. If you run the code again, now there would be 2 items processed successfully and other 2 remain in your mailbox.

1. 您的邮箱中收到了 8 封附有“.xml”文件的电子邮件。
2. 运行代码
3. 您将看到 8 个项目中只有 4 个成功处理，其他 4 个保留在它们的位置。
4. 如果您再次运行代码，现在将成功处理 2 个项目，另外 2 个保留在您的邮箱中。

Problem: After running the code, it is supposed to process all files and deletes them all not the half of them in each run. I want it to process all items at a single run.

问题：运行代码后，它应该处理所有文件并在每次运行中将它们全部删除而不是其中的一半。我希望它在一次运行中处理所有项目。

BTW, this code runs every time I open the Outlook.

顺便说一句，每次打开 Outlook 时都会运行此代码。

Private Sub Application_Startup()
'Initializing Application_Startup forces the macros to be accessible from other offic apps

'Process XML emails

Dim InboxMsg As Object

Dim DeletedItems As Outlook.Folder
Dim MsgAttachment As Outlook.Attachment
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.Folder

Dim fPathTemp As String
Dim fPathXML_SEM As String
Dim fPathEmail_SEM As String
Dim i As Long
Dim xmlDoc As New MSXML2.DOMDocument60
Dim xmlTitle As MSXML2.IXMLDOMNode
Dim xmlSupNum As MSXML2.IXMLDOMNode

    'Specify the folder where the attachments will be saved
    fPathTemp = "some directory, doesn't matter"
    fPathXML_SEM = "some directory, doesn't matter"
    fPathEmail_SEM = "some directory, doesn't matter"

    'Setup Outlook
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.Folders.Item("mailbox-name").Folders("Inbox")
    Set DeletedItems = ns.Folders.Item("mailbox-name").Folders("Deleted Items")


    'Loop through all Items in Inbox, find the xml attachements and process if they are the matching reponses
    'On Error Resume Next
    For Each InboxMsg In Inbox.Items
        If InboxMsg.Class = olMail Then 'if it is a mail item

            'Check for xml attachement
            For Each MsgAttachment In InboxMsg.Attachments

                If Right(MsgAttachment.DisplayName, 3) = "xml" Then

                    'Load XML and test for the title of the file
                    MsgAttachment.SaveAsFile fPathTemp & MsgAttachment.FileName
                    xmlDoc.Load fPathTemp & MsgAttachment.FileName
                    Set xmlTitle = xmlDoc.SelectSingleNode("//title")
                    Select Case xmlTitle.Text
                        Case "specific title"
                            'Get supplier number
                            Set xmlSupNum = xmlDoc.SelectSingleNode("//supplierNum")
                            'Save the XML to the correct folder
                            MsgAttachment.SaveAsFile fPathXML_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".xml"
                            'Save the email to the correct folder
                            InboxMsg.SaveAs fPathEmail_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".msg"
                            'Delete the message
                            InboxMsg.Move DeletedItems
                        Case Else

                    End Select
                    'Delete the temp file
                    On Error Resume Next
                    Kill fPathTemp & MsgAttachment.FileName
                    On Error GoTo 0
                    'Unload xmldoc
                    Set xmlDoc = Nothing
                    Set xmlTitle = Nothing
                    Set xmlSupNum = Nothing
                End If
            Next
        End If
    Next

    'Loop through deleted items and delete
    For Each InboxMsg In DeletedItems.Items
        InboxMsg.Delete
    Next

    'Clean-up
    Set InboxMsg = Nothing
    Set DeletedItems = Nothing
    Set MsgAttachment = Nothing
    Set ns = Nothing
    Set Inbox = Nothing
    i = 0

End Sub

回答by Jean-Fran?ois Corbett

Likely cause: When you do this InboxMsg.Move, all of the messages in your inbox after the one that was moved are bumped up by one position in the list. So you end up skipping some of them. This is a major annoyance with VBA's For Eachconstruct (and it doesn't seem to be consistent either).

可能的原因：当您执行此操作时InboxMsg.Move，收件箱中移动的邮件之后的所有邮件都会在列表中上升一个位置。所以你最终会跳过其中的一些。这是 VBAFor Each结构的一大烦恼（而且它似乎也不一致）。

Likely solution: Replace

可能的解决方案：更换

For Each InboxMsg In Inbox.Items

with

和

For i = Inbox.Items.Count To 1 Step -1 'Iterates from the end backwards
    Set InboxMsg = Inbox.Items(i)

This way you iterate backward from the end of the list. When you move a message to deleted items, then it doesn't matter when the following items in the list are bumped up by one, because you've already processed them anyway.

这样您就可以从列表的末尾向后迭代。当您将消息移至已删除项目时，列表中的以下项目何时增加一个并不重要，因为您已经处理了它们。

回答by Tim Williams

It's often not a good idea to modify the contents of a (sub)set of items while looping over them. You could modify your code so that it first identifies all of the items that need to be processed, and adds them to a Collection. Then process all the items in that collection.

在循环遍历项目（子）集时修改它们的内容通常不是一个好主意。您可以修改您的代码，使其首先识别所有需要处理的项目，并将它们添加到Collection. 然后处理该集合中的所有项目。

Basically you shouldn't be removing items from the Inbox while you're looping through its contents. First collect all the items you want to process (in your Inbox loop), then when you're done looping, process that collection of items.

基本上，您不应在循环浏览收件箱内容时从收件箱中删除项目。首先收集您想要处理的所有项目（在您的收件箱循环中），然后当您完成循环时，处理该项目集合。

Here's some pseudo-code which demonstrates this:

这是一些演示这一点的伪代码：

Private Sub Application_Startup()

    Dim collItems As New Collection

    'Start by identifying messages of interest and add them to a collection
    For Each InboxMsg In Inbox.Items
        If InboxMsg.Class = olMail Then 'if it is a mail item
            For Each MsgAttachment In InboxMsg.Attachments
                If Right(MsgAttachment.DisplayName, 3) = "xml" Then
                    collItems.Add InboxMsg
                    Exit For
                End If
            Next
        End If
    Next

    'now deal with the identified messages
    For Each InboxMsg In collItems
        ProcessMessage InboxMsg
    Next InboxMsg

    'Loop through deleted items and delete
    For Each InboxMsg In DeletedItems.Items
        InboxMsg.Delete
    Next

End Sub

Sub ProcessMessage(InboxMsg As Object)
    'deal with attachment(s) and delete message
End Sub