对于每个循环:在循环浏览Outlook邮箱以删除项目时会跳过某些项目

Question

我想开发以下VBA代码:

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

代码工作完美除外; 例如

1. 收到8封电子邮件,其中每个邮箱都附有".xml"文件.
2. 运行代码
3. 你会看到8个项目中只有4个被成功处理,其他4个仍然在他们的位置.
4. 如果再次运行代码,现在将成功处理2个项目,而其他2个项目仍保留在您的邮箱中.

问题:在运行代码之后,它应该处理所有文件并删除它们,而不是每次运行中的一半.我想让它在一次运行中处理所有项目.

顺便说一下,每次打开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

Answer 1

可能原因:当您执行此操作时InboxMsg.Move,收件箱中移动的邮件中的所有邮件都会被列表中的一个位置提升.所以你最终会跳过其中一些.这对VBA的For Each构造来说是一个主要的烦恼(它似乎也不一致).

可能的解决方案:替换

For Each InboxMsg In Inbox.Items

同

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

这样,您可以从列表末尾向后迭代.当您将邮件移动到已删除的项目时,列表中的以下项目被一个项目提升时无关紧要,因为您已经处理了它们.

Answer 2

在循环它们时修改(子)项集的内容通常不是一个好主意.您可以修改代码,使其首先标识需要处理的所有项目,然后将它们添加到a Collection.然后处理该集合中的所有项目.

基本上,当您循环浏览其内容时,不应该从收件箱中删除项目.首先收集您要处理的所有项目(在您的收件箱循环中),然后当您完成循环时,处理该项目集合.

这是一些伪代码,用于演示:

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