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

Заменить objSelection с Dim SubFolder As Outlook.MAPIFolder затем использовать 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