用于提取Excel附件的Outlook中的VBA代码

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