Код VBA в Outlook для извлечения вложений Excel

Question

Я пытаюсь загрузить все файлы расширения xlsx в папку из непрочитанных сообщений в моем почтовом ящике и пометить эти письма как прочитанные, а также дать уникальное соглашение об именах на основе временных меток.

До сих пор все, что я достиг не модифицировать код, который я нашел в Интернете

Sub GetAttachments() 
' This Outlook macro checks a the Outlook Inbox for messages 
' with attached files (of any type) and saves them to disk. 
' NOTE: make sure the specified save folder exists before 
' running the macro. 
    On Error GoTo GetAttachments_err 
' Declare variables 
    Dim ns As NameSpace 
    Dim Inbox As MAPIFolder 
    Dim Item As Object 
    Dim Atmt As Attachment 
    Dim FileName As String 
    Dim i As Integer 
    Set ns = GetNamespace("MAPI") 
    Set Inbox = ns.GetDefaultFolder(olFolderInbox) 
    i = 0 
' Check Inbox for messages and exit of none found 
    If Inbox.Items.Count = 0 Then 
     MsgBox "There are no messages in the Inbox.", vbInformation, _ 
       "Nothing Found" 
     Exit Sub 
    End If 
' Check each message for attachments 
    For Each Item In Inbox.Items 
' Save any attachments found 
     For Each Atmt In Item.Attachments 

    If Right(Atmt.FileName, 4) = "xlsx" Then 
      ' This path must exist! Change folder name as necessary. 
       FileName = "C:\Users\vduraiswamy\Desktop\attachments\" & _ 
        Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName 
       Atmt.SaveAsFile FileName 
       End If 
       Next Atmt 
    Next Item 
' Check filename of each attachment and save if it has "xls" extension 
      i = i + 1 
' Show summary message 
    If i > 0 Then 
     MsgBox "I found " & i & " attached files." _ 
     & vbCrLf & "I have saved them into the C:\Users\vduraiswamy\Desktop\attachments." _ 
     & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!" 
    Else 
     MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!" 
    End If 
' Clear memory 
GetAttachments_exit: 
    Set Atmt = Nothing 
    Set Item = Nothing 
    Set ns = Nothing 
    Exit Sub 
' Handle errors 
GetAttachments_err: 
    MsgBox "An unexpected error has occurred." _ 
     & vbCrLf & "Please note and report the following information." _ 
     & vbCrLf & "Macro Name: GetAttachments" _ 
     & vbCrLf & "Error Number: " & Err.Number _ 
     & vbCrLf & "Error Description: " & Err.Description _ 
     , vbCritical, "Error!" 
    Resume GetAttachments_exit 
End Sub 

Код дает ошибку, которая говорит, что «не в состоянии выполнить это действие такого типа подключения» на полпути после загрузки пары файлов.

Мне также хотелось бы, чтобы код просматривался только в непрочитанных сообщениях.

Answer 1

Sub GetAttachments() 
' This Outlook macro checks a the Outlook Inbox for messages 
' with attached files (of any type) and saves them to disk. 
' NOTE: make sure the specified save folder exists before 
' running the macro. 
    On Error GoTo GetAttachments_err 
' Declare variables 
    Dim ns As NameSpace 
    Dim Inbox As MAPIFolder 
    Dim Item As Object 
    Dim Atmt As Attachment 
    Dim FileName As String 
    Dim i As Integer 
    Set ns = GetNamespace("MAPI") 
    Set Inbox = ns.GetDefaultFolder(olFolderInbox) 
    i = 0 
' Check Inbox for messages and exit of none found 
    If Inbox.Items.Count = 0 Then 
     MsgBox "There are no messages in the Inbox.", vbInformation, _ 
       "Nothing Found" 
     Exit Sub 
    End If 
' Check each message for attachments 
    For Each Item In Inbox.Items 
     If Item.UnRead = True Then 'Add this for checking unread emails 
      ' Save any attachments found 
        For Each Atmt In Item.Attachments 
         If (Right(Atmt.FileName, 4) = "xlsx") Or (Right(Atmt.FileName, 4) = ".xls") Then 
         ' This path must exist! Change folder name as necessary. 
          FileName = "C:\Documents and Settings\epadillo\Desktop\test\" & _ 
           Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName 
          Atmt.SaveAsFile FileName 
          Item.UnRead = False 'Mark email item as read 
          i = i + 1 
         End If 
       Next Atmt 
     End If 
    Next Item 

' Show summary message 
    If i > 0 Then 
     MsgBox "I found " & i & " attached files." _ 
     & vbCrLf & "I have saved them into the C:\Users\vduraiswamy\Desktop\attachments." _ 
     & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!" 
    Else 
     MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!" 
    End If 
' Clear memory 
GetAttachments_exit: 
    Set Atmt = Nothing 
    Set Item = Nothing 
    Set ns = Nothing 
    Exit Sub 
' Handle errors 
GetAttachments_err: 
    MsgBox "An unexpected error has occurred." _ 
     & vbCrLf & "Please note and report the following information." _ 
     & vbCrLf & "Macro Name: GetAttachments" _ 
     & vbCrLf & "Error Number: " & Err.Number _ 
     & vbCrLf & "Error Description: " & Err.Description _ 
     , vbCritical, "Error!" 
    Resume GetAttachments_exit 
End Sub 

Answer 2

Попробуйте обходить вложения, не являющиеся документами.

 End If 
nonvalidAttachment: 
    Next Atmt 
Next Item 

Обычно вы работаете с номером, но здесь число не является постоянным, но описание является постоянным.

GetAttachments_err: 

If Err.Description = "Outlook cannot perform this action on this type of attachment." Then 
    Err.Clear 
    Resume nonvalidAttachment 
End if 

MsgBox "An unexpected error has occurred." _ 
     & vbCrLf & "Please note and report the following information." _ 
     & vbCrLf & "Macro Name: GetAttachments" _ 
     & vbCrLf & "Error Number: " & Err.Number _ 
     & vbCrLf & "Error Description: " & Err.Description _ 
     , vbCritical, "Error!" 
Resume GetAttachments_exit