Outlook - item aneh. Lampiran kesalahan

Saya memiliki kode berikut, yang seharusnya menyimpan file Excel tertentu yang dilampirkan ke email. Kode ini dikombinasikan dengan aturan, yang memicu skrip ini ketika email dengan subjek tertentu diterima. Kode dipicu, tetapi inilah kesalahan paling aneh yang saya lihat belakangan ini: itm.Attachments.Count tampak nol dan jelas file tersebut tidak disimpan! Tapi ... jika saya meletakkan breakpoint pada baris "Untuk setiap ..." dan tambahkan itm.Attachments.Count untuk menonton jendela, ditampilkan sebagai nol. Jika saya menambahkannya saja, kemudian telusuri ke properti Lampiran, lalu ke Properti hitung itu menunjukkan 1 untuk Hitung (sebagaimana mestinya) dan kode dieksekusi dengan baik. Saya menghabiskan setengah hari mencoba memahami apa yang sedang terjadi, tetapi saya tidak bisa mengetahuinya.

Perilaku ini sama pada Outlook 2010 x64 pada Windows 7 x64 dan Outlook 2010 x86 pada Windows 7 x86. Makro diaktifkan di Pusat Kepercayaan. Saya telah melampirkan beberapa tangkapan layar dengan pengaturan kode dan aturan dan juga sebuah film yang menunjukkan keanehan menonton windows.

Skrip ini dibuat beberapa waktu lalu, bekerja dengan baik pada beberapa PC dan didasarkan pada langkah-langkah dari sini: iterrors.com/outlook-automatically-save-an-outlook-attachment-to-disk/. Ada ide?

Adrian

Layar aturan di sini: https://drive.google.com/file/d/0Bw-aVIPSg4hsRFgxdzFtd3l1SkE/view?usp=sharing

1 mnt. film di sini: 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

Saya telah menjelajahi internet untuk mencari solusi untuk masalah ini, dan belum ada yang mengusulkan solusi. Inilah yang saya buat:

Masalah: Akun Email Outlook Tipe IMAP tidak mengunduh Tubuh dan Lampirannya saat pertama kali tiba. Pakar Outlook di mana-mana akan memberi tahu Anda bahwa Anda dapat menyesuaikan ini di Pengaturan Lanjut Outlook, tetapi, mereka salah, itu tidak akan berpengaruh.

Solusi 1: Beralih ke POP3. Dari sudut pandang pemrograman, ini menyelesaikan masalah, tetapi pendapat saya adalah bahwa jika Anda tidak dapat melakukannya dengan IMAP, maka Anda salah melakukannya, bukan?

Solusi 2: Perhatikan bahwa ini adalah kekuatan kasar, tetapi itu menyelesaikan pekerjaan. Di 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

Dalam modul terpisah:

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

Catatan: Saya menjadi pengguna StackExchange hanya untuk berbagi temuan ini dengan Anda. Saya suka, silakan maju dan menghubungkan jiwa-jiwa bermasalah lainnya dengan masalah yang sama di sini :).