Для каждого цикла: некоторые элементы пропускаются при циклическом просмотре почтового ящика Outlook для удаления элементов

Я хотел разработать код VBA, который:

1. Перебирает все элементы электронной почты в почтовом ящике
2. Если есть какие-либо другие элементы, скажем, «Приглашение календаря» пропускает этот элемент.
3. Находит электронные письма с вложениями
4. Если прикрепленный файл имеет расширение «.xml» и в нем есть определенный заголовок, сохраняет его в каталоге, если нет, он продолжает поиск
5. Помещает все электронные письма, содержащие вложения .xml, в Папка «Удаленные» после выполнения шага 4 и удаляет все электронные письма в этой папке в цикле.

Код работает идеально, ЗА ИСКЛЮЧЕНИЕМ; Например,

1. В вашем почтовом ящике получено 8 писем с прикрепленным к каждому из них файлом ".xml".
2. запустите код
3. вы увидите, что только 4 из 8 элементов успешно обработаны, остальные 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