CODEWITHSUNDEEP
vbaoutlook
Grzegorz Pyko
Grzegorz Pyko

Reputation: 25

Outlook scan specific folder and save all attachments from e-mails

I have this code to save attachments for selected items(mails) from my Outlook.

I would like to set the specific folder (define it) and Outlook will automatically scan all e-mails in that folder and save attachments.

Any ideas how should I expand this code to work that way? 

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

Upvotes: 1

Views: 2336

Answers (1)

0m3r
0m3r

Reputation: 12499

Replace your objSelection with Dim SubFolder As Outlook.MAPIFolder then use For Each objMsg In SubFolder.Items

also you don't need to create Outlook object if your running your code from Outlook CreateObject("Outlook.Application")

Make sure to update your folder name

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

To Run it from 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

Upvotes: 2

Related Questions