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

Question

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

如何使用脚本来完成？

Answer 1

此子例程会将在用户指定的 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

Answer 2

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