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对象，如果您从Outlook CreateObject("Outlook.Application")运行代码

确保更新您的文件夹名称

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