сохранить все вложения электронной почты в папке Outlook в папку

Question

У меня около 80 писем, все с вложениями, которые я хотел бы сохранить в папку на моем жестком диске. Вместо того, чтобы открывать каждое сообщение и идти для сохранения вложений, я ищу сценарий, который может это сделать? Кто-нибудь знает, как это можно сделать?

Спасибо,

Answer 1

Взгляните сюда: Save and remove attachments from email items (VBA)

Answer 2

Эта подпрограмма будет сохранять все вложения, найденные в указанной пользователем папке Outlook, в указанный пользователем каталог в файловой системе. Он также обновляет каждое сообщение ссылкой на очищенные файлы.

Он также содержит дополнительные комментарии, чтобы помочь подчеркнуть, как метод .Delete будет сжимать контейнеры вложений динамически (поиск «~~» в комментариях).

Этот макрос протестирован только на Outlook 2010.

' ------------------------------------------------------------ 
' Requires the following references: 
' 
' Visual Basic for Applications 
' Microsoft Outlook 14.0 Object Library 
' OLE Automation 
' Microsoft Office 14.0 Object Library 
' Microsoft Shell Controls and Automation 
' ------------------------------------------------------------ 

Public Sub SaveOLFolderAttachments() 

    ' Ask the user to select a file system folder for saving the attachments 
    Dim oShell As Object 
    Set oShell = CreateObject("Shell.Application") 
    Dim fsSaveFolder As Object 
    Set fsSaveFolder = oShell.BrowseForFolder(0, "Please Select a Save Folder:", 1) 
    If fsSaveFolder Is Nothing Then Exit Sub 
    ' Note: BrowseForFolder doesn't add a trailing slash 

    ' Ask the user to select an Outlook folder to process 
    Dim olPurgeFolder As Outlook.MAPIFolder 
    Set olPurgeFolder = Outlook.GetNamespace("MAPI").PickFolder 
    If olPurgeFolder Is Nothing Then Exit Sub 

    ' Iteration variables 
    Dim msg As Outlook.MailItem 
    Dim att As Outlook.attachment 
    Dim sSavePathFS As String 
    Dim sDelAtts 

    For Each msg In olPurgeFolder.Items 

    sDelAtts = "" 

    ' We check each msg for attachments as opposed to using .Restrict("[Attachment] > 0") 
    ' on our olPurgeFolder.Items collection. The collection returned by the Restrict method 
    ' will be dynamically updated each time we remove an attachment. Each update will 
    ' reindex the collection. As a result, it does not provide a reliable means for iteration. 
    ' This is why the For Each loops will not work. 
    If msg.Attachments.Count > 0 Then 

     ' This While loop is controlled via the .Delete method 
     ' which will decrement msg.Attachments.Count by one each time. 
     While msg.Attachments.Count > 0 

     ' Save the file 
     sSavePathFS = fsSaveFolder.Self.Path & "\" & msg.Attachments(1).FileName 
     msg.Attachments(1).SaveAsFile sSavePathFS 

     ' Build up a string to denote the file system save path(s) 
     ' Format the string according to the msg.BodyFormat. 
     If msg.BodyFormat <> olFormatHTML Then 
      sDelAtts = sDelAtts & vbCrLf & "<file://" & sSavePathFS & ">" 
     Else 
      sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sSavePathFS & "'>" & sSavePathFS & "</a>" 
     End If 

     ' Delete the current attachment. We use a "1" here instead of an "i" 
     ' because the .Delete method will shrink the size of the msg.Attachments 
     ' collection for us. Use some well placed Debug.Print statements to see 
     ' the behavior. 
     msg.Attachments(1).Delete 

     Wend 

     ' Modify the body of the msg to show the file system location of 
     ' the deleted attachments. 
     If msg.BodyFormat <> olFormatHTML Then 
     msg.Body = msg.Body & vbCrLf & vbCrLf & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts 
     Else 
     msg.HTMLBody = msg.HTMLBody & "<p></p><p>" & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts & "</p>" 
     End If 

     ' Save the edits to the msg. If you forget this line, the attachments will not be deleted. 
     msg.Save 

    End If 

    Next 

End Sub