Outlook 扫描特定文件夹并保存电子邮件中的所有附件

Question

我有这个代码来保存我的 Outlook 中选定项目（邮件）的附件。

我想设置特定文件夹（定义它），Outlook 将自动扫描该文件夹中的所有电子邮件并保存附件。

任何想法我应该如何扩展此代码以使其工作？

Public Sub SaveAttachments()

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 
Dim objAttachments As Outlook.Attachments
Dim objItems As Outlook.Items
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String

strFolderpath = "C:\Users\gpyko\Desktop\Pentaho project\HDPS RAPORTY"
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
strFolderpath = strFolderpath & "\Attachments\"

For Each objMsg In objSelection

  Set objAttachments = objMsg.Attachments
  lngCount = objAttachments.Count
  strDeletedFiles = ""

  If lngCount > 0 Then

    For i = lngCount To 1 Step -1

      strFile = objAttachments.Item(i).FileName
      strFile = strFolderpath & strFile
      objAttachments.Item(i).SaveAsFile strFile
      objAttachments.Item(i).Delete

      If objMsg.BodyFormat <> olFormatHTML Then

            strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
      Else
            strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
            strFile & "'>" & strFile & "</a>"
      End If

    Next i

      If objMsg.BodyFormat <> olFormatHTML Then

          objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
      Else
          objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
      End If
      objMsg.Save

  End If

Next

ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

Answer 1

用 Dim SubFolder As Outlook.MAPIFolder 替换你的 objSelection 然后使用 For Each objMsg In SubFolder.Items

如果您从 Outlook CreateObject("Outlook.Application") 运行代码，您也不需要创建 Outlook 对象

确保更新您的文件夹名称

Set SubFolder = olNs.GetDefaultFolder(olFolderInbox).Folders("Folder Name")

Option Explicit
Public Sub SaveAttachments()
    Dim olNs As Outlook.NameSpace
    Dim objMsg As Outlook.MailItem
    Dim objAttachments As Outlook.Attachments
    Dim objItems As Outlook.Items
    Dim SubFolder As Outlook.MAPIFolder
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String
    Dim strDeletedFiles As String

    strFolderpath = "C:\Users\gpyko\Desktop\Pentaho project\HDPS RAPORTY"

    Set olNs = Application.GetNamespace("MAPI")

    Set SubFolder = olNs.GetDefaultFolder(olFolderInbox).Folders("Folder Name")

    strFolderpath = strFolderpath & "\Attachments\"


    For Each objMsg In SubFolder.Items
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
        strDeletedFiles = ""

        If lngCount > 0 Then

            For i = lngCount To 1 Step -1

            strFile = objAttachments.Item(i).FileName
            strFile = strFolderpath & strFile
            objAttachments.Item(i).SaveAsFile strFile
            objAttachments.Item(i).Delete

            If objMsg.BodyFormat <> olFormatHTML Then

                strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
            Else
                strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
                strFile & "'>" & strFile & "</a>"
            End If

            Next i

            If objMsg.BodyFormat <> olFormatHTML Then

                objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
            Else
                objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
            End If

            objMsg.Save

        End If
    Next


ExitSub:
    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set SubFolder = Nothing
    Set olNs = Nothing
End Sub

---

从 Excel 运行它。

Option Explicit
Public Sub SaveAttachments()
    Dim App As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim objMsg As Outlook.MailItem
    Dim objAttachments As Outlook.Attachments
    Dim objItems As Outlook.Items
    Dim SubFolder As Outlook.MAPIFolder
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String
    Dim strDeletedFiles As String

    strFolderpath = "C:\Users\gpyko\Desktop\Pentaho project\HDPS RAPORTY"
    Set App = New Outlook.Application
    Set olNs = App.GetNamespace("MAPI")

    Set SubFolder = olNs.GetDefaultFolder(olFolderInbox).Folders("Folder Name")

    strFolderpath = strFolderpath & "\Attachments\"


    For Each objMsg In SubFolder.Items
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
        strDeletedFiles = ""

        If lngCount > 0 Then

            For i = lngCount To 1 Step -1

            strFile = objAttachments.Item(i).Filename
            strFile = strFolderpath & strFile
            objAttachments.Item(i).SaveAsFile strFile
            objAttachments.Item(i).Delete

            If objMsg.BodyFormat <> olFormatHTML Then

                strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
            Else
                strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
                strFile & "'>" & strFile & "</a>"
            End If

            Next i

            If objMsg.BodyFormat <> olFormatHTML Then

                objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
            Else
                objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
            End If

            objMsg.Save

        End If
    Next

ExitSub:
    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set SubFolder = Nothing
    Set olNs = Nothing
End Sub