vba 将 Outlook 文件夹中的所有电子邮件附件保存到 Windows 文件夹

Save all email attachments in Outlook folder to Windows folder

提问by thegunner

I have about 80 emails, all with attachments which I would like to save to a folder on my hard drive.

我有大约 80 封电子邮件，都带有附件，我想将它们保存到硬盘驱动器上的文件夹中。

How this can be done with a script?

如何使用脚本完成此操作？

采纳答案by Rubens Farias

Take a look here: Save and remove attachments from email items (VBA)

在这里查看：保存和删除电子邮件项目中的附件 (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

回答by RNV

This subroutine will save all attachments found in a user specified Outlook folder to a user specified directory on the file system. It also updates each message with a link to the purged files.

此子例程将在用户指定的 Outlook 文件夹中找到的所有附件保存到文件系统上的用户指定目录中。它还使用指向已清除文件的链接更新每条消息。

It also contains extra comments to help highlight how the .Delete method will shrink Attachment containers dynamically (search for "~~" in the comments).

它还包含额外的注释，以帮助突出 .Delete 方法如何动态缩小附件容器（在注释中搜索“~~”）。

This macro is only tested on Outlook 2010.

此宏仅在 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