用於提取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