Outlook - elemento extraño. Error de adjuntos

Tengo el siguiente código, que debería guardar un archivo de Excel específico adjunto a un correo electrónico. El código se combina con una regla, que activa este script cuando se recibe un correo electrónico con un asunto específico. El código se activa, pero aquí aparece el error más extraño que he visto últimamente: itm.Attachments.Count parece ser cero y obviamente el archivo no está guardado. Pero ... si coloco un punto de interrupción en la línea "Para cada ..." y agrego itm.Attachments.Count para ver la ventana, se muestra como cero. Si agrego itm only, luego navega a la propiedad Attachments, luego a Count property muestra 1 para Count (como debería) y el código se ejecuta correctamente. Me pasé medio día tratando de entender lo que está pasando, pero no puedo entenderlo.

El comportamiento es el mismo tanto en un Outlook 2010 x64 en un Windows 7 x64 como en un Outlook 2010 x86 en un Windows 7 x86. Las macros están habilitadas en el Centro de Confianza. He adjuntado algunas capturas de pantalla con el código y la configuración de las reglas, y también una película que muestra la extrañeza de las ventanas del reloj.

La secuencia de comandos se creó hace algún tiempo, funcionó bien en un par de PC y se basó en los pasos de aquí: iterrors.com/outlook-automatically-save-an-outlook-attachment-to-disk/. ¿Algunas ideas?

Adrián

Regla de pantalla aquí: https://drive.google.com/file/d/0Bw-aVIPSg4hsRFgxdzFtd3l1SkE/view?usp=sharing

1 minuto. pelicula aqui https://drive.google.com/file/d/0Bw-aVIPSg4hsZERQWUJHLXd4bjA/view?usp=sharing

Public Sub Kona(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    saveFolder = "C:\test"
    For Each objAtt In itm.Attachments
        If InStr(objAtt.DisplayName, "Kona Preferred Fixed Price Matrix (ALL)") Then
            objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
        End If
        Set objAtt = Nothing
    Next
End Sub

He buscado en internet una solución a este problema, y ​​nadie parece haber propuesto una solución todavía. Esto es lo que he encontrado:

El problema: Las cuentas de correo electrónico de Outlook de tipo IMAP no descargan su cuerpo y archivos adjuntos cuando llegan por primera vez. Los expertos de Outlook en todas partes le dirán que puede ajustar esto en la Configuración avanzada de Outlook, pero están equivocados y eso no tendrá ningún efecto.

Solución 1: Cambiar a POP3. Desde el punto de vista de la programación, esto resuelve el problema, pero mi opinión es que si no puedes hacerlo con IMAP, lo estás haciendo mal, ¿verdad?

Solución 2: Tenga en cuenta que esto es una fuerza bruta, pero hace el trabajo. En ThisOutlookSession:

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
  Dim objOutlook As Object
  Dim objNameSpace As Object

  Set objOutlook = Outlook.Application
  Set objNameSpace = objOutlook.GetNamespace("MAPI")

  'I am using this code on my gmail
  Set Items = objNameSpace.Folders("[email protected]").Folders("Inbox").Items
End Sub
Private Sub Items_ItemAdd(ByVal objItem As Object)
    Dim objExcel As Object
    Dim objMsg As Object
    Dim Atmt As Outlook.Attachment
    Dim Atmts As Outlook.Attachments
    Dim objFSO As Object
    Dim objFile As Object
    Dim strFilePath As String
    Dim strBody As String

    On Error GoTo ErrorHandler
    If TypeName(objItem) = "MailItem" Then
        Set objMsg = objItem
        If objMsg.DownloadState <> 1 Then
            objMsg.Display
            objMsg.Close (1)
            Set objMsg = Nothing
            DoEvents
            Sleep (1000) 'Need a pause or the loop runs to fast and kills Outlook
            RetryMailEvent objItem
        Else
            strBody = objMsg.Body

            Set Atmts = objMsg.Attachments

            For Each Atmt In Atmts
                If Right$(Atmt.FileName, 3) = "txt" Then
                    Set objFSO = CreateObject("Scripting.FileSystemObject")
                    strFilePath = "C:\temp\" & Format(objItem.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
                    Atmt.SaveAsFile strFilePath
                    Set objFile = objFSO.OpenTextFile(strFilePath, 1)
                    strBody = strBody & "[Attatchment] " & objFile.ReadAll & " [/Attatchment]"

                    objFile.Close
                    Kill strFilePath
                End If
            Next Atmt

            'Any additional Code you want to run goes here

        End If
    End If
ProgramExit:
    Set objMsg = Nothing
    Set objExcel = Nothing
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
End Sub

En un módulo separado:

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub RetryMailEvent(ByVal objItem As Object)
    Dim objExcel As Object
    Dim objMsg As Object
    Dim Atmt As Outlook.Attachment
    Dim Atmts As Outlook.Attachments
    Dim objFSO As Object
    Dim objFile As Object
    Dim strFilePath As String
    Dim strBody As String

    On Error GoTo ErrorHandler
    If TypeName(objItem) = "MailItem" Then
        Set objMsg = objItem
        If objMsg.DownloadState <> 1 Then
            Set objMsg = Nothing
            DoEvents
            Sleep (1000) 'Need a pause or the loop runs to fast and kills Outlook
            RetryMailEvent objItem
        Else
            strBody = objMsg.Body

            Set Atmts = objMsg.Attachments

            For Each Atmt In Atmts
                If Right$(Atmt.FileName, 3) = "txt" Then
                    Set objFSO = CreateObject("Scripting.FileSystemObject")
                    strFilePath = "C:\temp\" & Format(objItem.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
                    Atmt.SaveAsFile strFilePath
                    Set objFile = objFSO.OpenTextFile(strFilePath, 1)
                    strBody = strBody & "[Attatchment] " & objFile.ReadAll & " [/Attatchment]"

                    objFile.Close
                    Kill strFilePath
                End If
            Next Atmt

            'Any additional Code you want to run goes here

        End If
    End If
ProgramExit:
    Set objMsg = Nothing
    Set objExcel = Nothing
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
End Sub

Nota: Me convertí en un usuario de StackExchange solo para compartir estos hallazgos con usted. Si te gusta, por favor ve y vincula otras almas con problemas con problemas similares aquí :).