Salve todos os anexos de e -mail na pasta do Outlook na pasta

Question

Tenho cerca de 80 e -mails, todos com anexos que gostaria de economizar em uma pasta no meu disco rígido. Em vez de abrir cada mensagem e ir para salvar anexos, estou procurando um script que possa fazer isso? Alguém sabe de como isso pode ser feito?

Obrigado,

Answer 1

Dê uma olhada aqui: Salve e remova os anexos dos itens de e -mail (VBA)

Sub SaveAttachment()

    'Declaration
    Dim myItems, myItem, myAttachments, myAttachment As Object
    Dim myOrt As String
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection

    'Ask for destination folder
    myOrt = InputBox("Destination", "Save Attachments", "C:\")

    On Error Resume Next

    'work on selected items
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection

    'for all items do...
    For Each myItem In myOlSel

        'point on attachments
        Set myAttachments = myItem.Attachments

        'if there are some...
        If myAttachments.Count > 0 Then

            'add remark to message text
            myItem.Body = myItem.Body & vbCrLf & _
                "Removed Attachments:" & vbCrLf

            'for all attachments do...
            For i = 1 To myAttachments.Count

                'save them to destination
                myAttachments(i).SaveAsFile myOrt & _
                    myAttachments(i).DisplayName

                'add name and destination to message text
                myItem.Body = myItem.Body & _
                    "File: " & myOrt & _
                    myAttachments(i).DisplayName & vbCrLf

            Next i

            'for all attachments do...
            While myAttachments.Count > 0

                'remove it (use this method in Outlook XP)
                'myAttachments.Remove 1

                'remove it (use this method in Outlook 2000)
                myAttachments(1).Delete

            Wend

            'save item without attachments
            myItem.Save
        End If

    Next

    'free variables
    Set myItems = Nothing
    Set myItem = Nothing
    Set myAttachments = Nothing
    Set myAttachment = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing

End Sub

Answer 2

Esta sub -rotina salvará todos os anexos encontrados em uma pasta do Outlook especificada pelo usuário em um diretório especificado pelo usuário no sistema de arquivos. Ele também atualiza cada mensagem com um link para os arquivos purgados.

Ele também contém comentários extras para ajudar a destacar como o método .Delete diminuirá dinamicamente os contêineres de fixação (procure "~~" nos comentários).

Esta macro é testada apenas no 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