Looping through specific Outlook folder mail items

Question

I am trying to set up a rule in Outlook to use VBA to automatically download Outlook attachments to a specific folder.

I have code that works for selected items.

Here is where it determines the selection to loop through

Set objSelection = objOL.Activeexplorer.selection

Instead of a selection I would like to use the "Found Folder" which is a function to find and set "Foundfolder" variable as desired folder.

Public Sub SaveAttachmentsAlex()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
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
Dim N As Long
Dim FoundFolder As Folder

Set FoundFolder = FindInFolders(Application.Session.Folders, "Folder to check")


' Get the path to your My Documents folder
strFolderpath = "L:\"
On Error Resume Next

' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")

' Get the collection of selected objects.
Set objSelection = objOL.Activeexplorer.selection
‘FoundFolder.

' Set the Attachment folder.
''''''''strFolderpath = strFolderpath & "\Attachments\"

' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
N = 1
For Each objMsg In objSelection

    ' This code only strips attachments from mail items.
    ' If objMsg.class=olMail Then
    ' Get the Attachments collection of the item.
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    strDeletedFiles = ""

    If lngCount > 0 Then

        ' We need to use a count down loop for removing items
        ' from a collection. Otherwise, the loop counter gets
        ' confused and only every other item is removed.

        For i = lngCount To 1 Step -1

            ' Save attachment before deleting from item.
            ' Get the file name.
            strFile = objAttachments.Item(i).FileName
            strFile = N & " - " & strFile

            ' Combine with the path to the Temp folder.
            strFile = strFolderpath & strFile

            ' Save the attachment as a file.
            objAttachments.Item(i).SaveAsFile strFile

            ' Delete the attachment.
            objAttachments.Item(i).Delete

            'write the save as path to a string to add to the message
            'check for html and use html tags in link
            If objMsg.BodyFormat <> olFormatHTML Then
                strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
            Else
                strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
                strFile & "'>" & strFile & "</a>"
            End If

            'Use the MsgBox command to troubleshoot. Remove it from the final code.
            'MsgBox strDeletedFiles

        Next i
        N = N + 1
        ' Adds the filename string to the message body and save it
        ' Check for HTML body
        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

Function FindInFolders(TheFolders As Outlook.Folders, Name As String)
  Dim SubFolder As Outlook.MAPIFolder
  
  On Error Resume Next
  
  Set FindInFolders = Nothing
  
  For Each SubFolder In TheFolders
    If LCase(SubFolder.Name) Like LCase(Name) Then
      Set FindInFolders = SubFolder
      Exit For
    Else
      Set FindInFolders = FindInFolders(SubFolder.Folders, Name)
      If Not FindInFolders Is Nothing Then Exit For
    End If
  Debug.Print SubFolder
  Next
End Function

Where does the folder exist in relationship to other folders? — Dmitry Streblechenko, Jul 20 '22 at 15:31
Note: Due to `On Error Resume Next` if `strFolderpath` is not valid then the "Path does not exist." error is bypassed. The attachments will not be saved before being deleted. — niton, Jul 20 '22 at 16:51
Does this answer your question? [Iterate all email items in a specific Outlook folder](https://stackoverflow.com/questions/21556389/iterate-all-email-items-in-a-specific-outlook-folder) — niton, Jul 20 '22 at 20:35

score 0 · Answer 1 · answered Jul 21 '22 at 15:25

Instead of iterating over selected items in the explorer window:

' Get the collection of selected objects.
Set objSelection = objOL.Activeexplorer.selection

You need to get the current folder from the active explorer window and iterate over items. For example:

Dim folder as Outlook.MAPIFolder
Dim items as Outlook.Items
Dim item as Object

Set folder = objOL.Activeexplorer.CurrentFolder
Set items = folder.Items

For Each item In objSelection
  ' loop through all items there

Be aware, Outlook folders may contain different kind of items in the folder. So, I'd suggest checking the item type before casting the object to the MailItem type. You may check the MessageClass property to make sure you deal with a real mail item.

Anyway, looping through all items in the folder is not really a good idea. I'd recommend using the Find/FindNext or Restrict methods of the Items class instead. In that case you will get only items that correspond to your conditions and all the job will be done by the store provider (which is much faster). Read more about these methods in the following articles:

score 0 · Answer 2 · answered Oct 10 '22 at 21:38

The quick answer is For Each objMsg In FoundFolder.items.

The long answer addresses the misuse of On Error Resume Next which could lead to attachments being deleted without first being saved.

Option Explicit

Public Sub SaveAttachmentsAlex()

Dim objMsg As Object    ' <---
Dim objAttachments As Attachments

Dim i As Long
Dim lngCount As Long

Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String

Dim n As Long
Dim FoundFolder As Folder

' Reference Microsoft Scripting Runtime
Dim fso As Scripting.FileSystemObject

Set fso = New Scripting.FileSystemObject

' Set the Attachment folder.
strFolderpath = "L:\"

If fso.folderExists(strFolderpath) Then
    
    Set FoundFolder = FindInFolders(Session.Folders, "Folder to check")

    If Not FoundFolder Is Nothing Then
    
        For Each objMsg In FoundFolder.Items
            
            ' Check each folder item for attachments. If attachments exist,
            '  save them to the strFolderPath folder and strip them from the item.
            n = 1
        
            ' This code only strips attachments from mail items.
            If objMsg.Class = olMail Then
            
                ' Get the Attachments collection of the item.
                Set objAttachments = objMsg.Attachments
                lngCount = objAttachments.count
                strDeletedFiles = ""
            
                If lngCount > 0 Then
            
                    ' Use a count down loop for removing items from a collection,
                    '  otherwise, only every other item is skipped.
                    
                    For i = lngCount To 1 Step -1
            
                        ' Save attachment before deleting from item.
                        
                        ' Get the file name.
                        strFile = objAttachments.Item(i).fileName
                        strFile = n & " - " & strFile
            
                        ' Combine with the path to the target file folder.
                        strFile = strFolderpath & strFile
            
                        ' Save the attachment as a file.
                        objAttachments.Item(i).SaveAsFile strFile
            
                        ' Delete the attachment.
                        objAttachments.Item(i).Delete
            
                        ' Write the save as path to a string to add to the message
                        ' Check for html and use html tags in link
                        If objMsg.BodyFormat <> olFormatHTML Then
                            strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
                        Else
                            strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
                              strFile & "'>" & strFile & "</a>"
                        End If
            
                    Next i
                    
                    n = n + 1
                    ' Add the filename string to the message body and save it
                    ' Check for HTML body
                    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
            
            End If
            
        Next
        
    Else
    
        Debug.Print "Source Outlook folder not found."
    
    End If
    
Else
    
    Debug.Print "Target file folder not found."
    
End If

End Sub

Function FindInFolders(TheFolders As Folders, Name As String)

    Dim SubFolder As Folder
        
    Set FindInFolders = Nothing
    
    For Each SubFolder In TheFolders
        
        If LCase(SubFolder.Name) Like LCase(Name) Then
            Set FindInFolders = SubFolder
            Exit For
        Else
            Set FindInFolders = FindInFolders(SubFolder.Folders, Name)
            If Not FindInFolders Is Nothing Then Exit For
        End If
        
    Next
    
End Function

Looping through specific Outlook folder mail items

2 Answers2