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