Para Cada bucle: Algunos elementos se omiten cuando bucle a través de buzón de Outlook para eliminar elementos

Question

que quería desarrollar código VBA que:

1. recorre todos los elementos de correo electrónico en el buzón
2. Si hay cualquier tipo de otra los elementos dicen "Invitación de calendario" se salta ese elemento.
3. entera de los mensajes de correo electrónico con archivos adjuntos
4. Si el archivo adjunto tiene extensión ".xml" y un título específico en él, lo guarda en un directorio, si no se sigue buscando
5. pone todos los archivos adjuntos de correo electrónico incluye a .xml Carpeta "Elementos eliminados" después de hacer el paso 4 y elimina todos los correos electrónicos en esa carpeta mediante un bucle.

El código funciona perfecto EXCEPTO; Por ejemplo

1. hay 8 correo electrónico recibido con el archivo ".xml" adjunta a cada uno de ellos en su buzón de correo.
2. ejecuta el código
3. verá que solo 4 de los 8 elementos se procesaron correctamente, otros 4 permanecen en sus posiciones.
4. Si ejecuta el código nuevamente, ahora habrá 2 elementos procesados ​​correctamente y otros 2 permanecerán en su buzón.

Problema: después de ejecutar el código, se supone que debe procesar todos los archivos y eliminarlos, no la mitad de ellos en cada ejecución. Quiero que procese todos los elementos en una sola ejecución.

Por cierto, este código se ejecuta cada vez que abro 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

causa probable: Al hacer esto InboxMsg.Move, todos los mensajes en su bandeja de entrada después de la que se ha movido es golpeado por una posición en el lista. Así que terminas saltándote algunos de ellos. Esto es una gran molestia con la construcción For Each de VBA (y tampoco parece ser consistente).

Posible solución: reemplazar

For Each InboxMsg In Inbox.Items 

con

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

De esta manera se itera hacia atrás desde el final de la lista.Cuando mueve un mensaje a los elementos eliminados, no importa cuando los elementos siguientes en la lista se incrementan en uno, porque ya los ha procesado de todos modos.

Answer 2

A menudo no es una buena idea modificar el contenido de un (sub) conjunto de elementos al alternarlos. Puede modificar su código para que primero identifique todos los elementos que deben procesarse y los agregue a un Collection. Luego procesa todos los elementos en esa colección.

Básicamente, no debe eliminar elementos de la Bandeja de entrada mientras revisa su contenido. Primero recopile todos los elementos que desea procesar (en su bucle de Bandeja de entrada), luego, cuando termine de bifurcar, procese esa colección de elementos.

He aquí algunos pseudo-código que demuestra esto:

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