asked on

Loop through subfolders in outlook exporting attachments in them

I am only able to export attachments in specified subfolders (eg "free 1") at a time, but not able to loop through all subfolders (eg. Free 1, Free 2) to export the attachments. Have looked at available solutions but could not mould my code to make it work... Can you please advice on what i am doing wrong ? Below is what I have used. Many Thanks.

Sub ExportAttachments()

On Error GoTo ExportAttachments_err:


Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim Filename As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult


Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders("Personal Folders").Folders("Freezone")
Set SubFolder = Inbox.Folders("Free 1")
i = 0

'For Each SubFolder In Inbox.Items


If SubFolder.Items.Count = 0 Then
    MsgBox "There are no messages in the SubFolder.", vbInformation, _
            "Nothing Found"
    Exit Sub
End If


If SubFolder.Items.Count > 0 Then
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
            If Right(Atmt.Filename, 3) = "csv" Or Right(Atmt.Filename, 3) = "xls" Or Right(Atmt.Filename, 4) = "xlsx" Or Right(Atmt.Filename, 3) = "pdf" Then
                        Filename = "C:\Proven File Attachments\" & _
                    Atmt.Filename & " - " & Format(Item.ReceivedTime, "ddmmyyyy_hhnn")
                Atmt.SaveAsFile Filename
                i = i + 1
            End If
        Next Atmt
    Next Item
End If


If i > 0 Then
    varResponse = MsgBox("There were " & i & " attached files." _
        & vbCrLf & " The files have been saved in the C:\Proven File Attachments folder." _
        & vbCrLf & vbCrLf & "Would you like to view the files now?", vbQuestion + vbYesNo, "Finished!")
    If varResponse = vbYes Then
        Shell "Explorer.exe /e,C:\Proven File Attachments", vbNormalFocus
    End If
Else
    MsgBox "No files were found in your mail.", vbInformation, "Finished!"

End If


'Next


ExportAttachments_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub


ExportAttachments_err:
    MsgBox "An unexpected error has occurred." _
    & vbCrLf & "Please note and report the following information." _
    & vbCrLf & "Macro Name: ExportAttachments" _
    & vbCrLf & "Error Number: " & Err.Number _
    & vbCrLf & "Error Description: " & Err.Description _
    , vbCritical, "Error!"
Resume ExportAttachments_exit
Exit Sub
    
    



End Sub

Open in new window

Chris Bottomley

Try using a sub that can be made re-entrant. The following ought to work so see how it goes.

Essentially I have extracted the folder code from your sub put it into a sub on it's own along with a recursive call to itself.

Chris

Sub ExportAttachments()

On Error GoTo ExportAttachments_err:


Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim Filename As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult


Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders("Personal Folders").Folders("Freezone")
Set SubFolder = Inbox.Folders("Free 1")
i = 0

'For Each SubFolder In Inbox.Items


If SubFolder.Items.Count = 0 Then
    MsgBox "There are no messages in the SubFolder.", vbInformation, _
            "Nothing Found"
    Exit Sub
End If


If SubFolder.Items.Count > 0 Then
   iterFolder subfolder, item
End If


If i > 0 Then
    varResponse = MsgBox("There were " & i & " attached files." _
        & vbCrLf & " The files have been saved in the C:\Proven File Attachments folder." _
        & vbCrLf & vbCrLf & "Would you like to view the files now?", vbQuestion + vbYesNo, "Finished!")
    If varResponse = vbYes Then
        Shell "Explorer.exe /e,C:\Proven File Attachments", vbNormalFocus
    End If
Else
    MsgBox "No files were found in your mail.", vbInformation, "Finished!"

End If


'Next


ExportAttachments_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub


ExportAttachments_err:
    MsgBox "An unexpected error has occurred." _
    & vbCrLf & "Please note and report the following information." _
    & vbCrLf & "Macro Name: ExportAttachments" _
    & vbCrLf & "Error Number: " & Err.Number _
    & vbCrLf & "Error Description: " & Err.Description _
    , vbCritical, "Error!"
Resume ExportAttachments_exit
Exit Sub
End Sub


sub iterFolder(dim subfolder as object, dim item as object)
dim atmt as object
dim fldr as object
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
            If Right(Atmt.Filename, 3) = "csv" Or Right(Atmt.Filename, 3) = "xls" Or Right(Atmt.Filename, 4) = "xlsx" Or Right(Atmt.Filename, 3) = "pdf" Then
                        Filename = "C:\Proven File Attachments\" & _
                    Atmt.Filename & " - " & Format(Item.ReceivedTime, "ddmmyyyy_hhnn")
                Atmt.SaveAsFile Filename
                i = i + 1
            End If
        Next Atmt
    Next Item
    for each fldr in subfolder.folders
       iterFolder subfolder, item
    next
End sub

Open in new window

Chris Bottomley

Short of testing on my active inbox I would have to create a test environment so the code is untested ... I see on posting however a bug with regard to parameters so modified here.

Chris

Sub ExportAttachments()

On Error GoTo ExportAttachments_err:


Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim Filename As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult


Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders("Personal Folders").Folders("Freezone")
Set SubFolder = Inbox.Folders("Free 1")
i = 0

'For Each SubFolder In Inbox.Items


If SubFolder.Items.Count = 0 Then
    MsgBox "There are no messages in the SubFolder.", vbInformation, _
            "Nothing Found"
    Exit Sub
End If


If SubFolder.Items.Count > 0 Then
   iterFolder subfolder
End If


If i > 0 Then
    varResponse = MsgBox("There were " & i & " attached files." _
        & vbCrLf & " The files have been saved in the C:\Proven File Attachments folder." _
        & vbCrLf & vbCrLf & "Would you like to view the files now?", vbQuestion + vbYesNo, "Finished!")
    If varResponse = vbYes Then
        Shell "Explorer.exe /e,C:\Proven File Attachments", vbNormalFocus
    End If
Else
    MsgBox "No files were found in your mail.", vbInformation, "Finished!"

End If


'Next


ExportAttachments_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub


ExportAttachments_err:
    MsgBox "An unexpected error has occurred." _
    & vbCrLf & "Please note and report the following information." _
    & vbCrLf & "Macro Name: ExportAttachments" _
    & vbCrLf & "Error Number: " & Err.Number _
    & vbCrLf & "Error Description: " & Err.Description _
    , vbCritical, "Error!"
Resume ExportAttachments_exit
Exit Sub
End Sub


sub iterFolder(dim subfolder as object)
dim atmt as object
dim fldr as object
dim item as object
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
            If Right(Atmt.Filename, 3) = "csv" Or Right(Atmt.Filename, 3) = "xls" Or Right(Atmt.Filename, 4) = "xlsx" Or Right(Atmt.Filename, 3) = "pdf" Then
                        Filename = "C:\Proven File Attachments\" & _
                    Atmt.Filename & " - " & Format(Item.ReceivedTime, "ddmmyyyy_hhnn")
                Atmt.SaveAsFile Filename
                i = i + 1
            End If
        Next Atmt
    Next Item
    for each fldr in subfolder.folders
       iterFolder subfolder
    next
End sub

Open in new window

Chris Bottomley

I have modified my folder and the code to do a test ... there are in fact a few bugs that I am working on please hold off using the supplied code

Chris

Chris Bottomley

The following is the result of the corrections following a test, hopefully I have undone all teh test changes.

Chris

Sub ExportAttachments()

On Error GoTo ExportAttachments_err:


Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim subfolder As MAPIFolder
Dim item As Object
Dim atmt As Attachment
Dim Filename As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult


Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders("Personal Folders").Folders("Freezone")
Set SubFolder = Inbox.Folders("Free 1")
i = 0

'For Each SubFolder In Inbox.Items


If subfolder.Items.count = 0 Then
    MsgBox "There are no messages in the SubFolder.", vbInformation, _
            "Nothing Found"
    Exit Sub
End If


If subfolder.Items.count > 0 Then
   iterFolder subfolder, i
End If


If i > 0 Then
    varResponse = MsgBox("There were " & i & " attached files." _
        & vbCrLf & " The files have been saved in the C:\Proven File Attachments folder." _
        & vbCrLf & vbCrLf & "Would you like to view the files now?", vbQuestion + vbYesNo, "Finished!")
    If varResponse = vbYes Then
        Shell "Explorer.exe /e,C:\Proven File Attachments", vbNormalFocus
    End If
Else
    MsgBox "No files were found in your mail.", vbInformation, "Finished!"

End If


'Next


ExportAttachments_exit:
    Set atmt = Nothing
    Set item = Nothing
    Set ns = Nothing
    Exit Sub


ExportAttachments_err:
    MsgBox "An unexpected error has occurred." _
    & vbCrLf & "Please note and report the following information." _
    & vbCrLf & "Macro Name: ExportAttachments" _
    & vbCrLf & "Error Number: " & err.Number _
    & vbCrLf & "Error Description: " & err.description _
    , vbCritical, "Error!"
Resume ExportAttachments_exit
Exit Sub
End Sub


Sub iterFolder(subfolder As Object, intCount As Integer)
Dim atmt As Object
Dim fldr As Object
Dim item As Object
    For Each item In subfolder.Items
        For Each atmt In item.Attachments
            If Right(atmt.Filename, 3) = "csv" Or Right(atmt.Filename, 3) = "xls" Or Right(atmt.Filename, 4) = "xlsx" Or Right(atmt.Filename, 3) = "pdf" Then
                        Filename = "C:\Proven File Attachments\" & _
                    atmt.Filename & " - " & Format(item.ReceivedTime, "ddmmyyyy_hhnn")
                atmt.SaveAsFile Filename
                intCount = intCount + 1
            End If
        Next atmt
    Next item
    For Each fldr In subfolder.folders
       iterFolder fldr, intCount
    Next
End Sub

Open in new window

kwthomp

ASKER

Thanks chris.
But It appears to focus only on the named subfolder, and does not loop through the rest of the folders.

Chris Bottomley

Let me scale up a test before I respond

Chris

Chris Bottomley

I've just looped through a number of subfolders off (and including) inbox with no problem. Can you indicate why you think the post does not ... i'll append some code in a minute to try and report what is happening

Chris

Chris Bottomley

This is the same code but with some extra attached to report folders processed. I have hopefully added the required changes for the report but apologies if there is a bug as again thi sis reconstructed from my test example.

Chris

Sub ExportAttachments()

On Error GoTo ExportAttachments_err:


Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim subfolder As MAPIFolder
Dim item As Object
Dim atmt As Attachment
Dim Filename As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
Dim str As String

Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders("Personal Folders").Folders("Freezone")
Set SubFolder = Inbox.Folders("Free 1")
i = 0

'For Each SubFolder In Inbox.Items


If subfolder.Items.count = 0 Then
    MsgBox "There are no messages in the SubFolder.", vbInformation, _
            "Nothing Found"
    Exit Sub
End If


If subfolder.Items.count > 0 Then
   iterFolder subfolder, i, str
End If

MsgBox str, vbOKOnly + vbInformation, "Folders processed"

If i > 0 Then
    varResponse = MsgBox("There were " & i & " attached files." _
        & vbCrLf & " The files have been saved in the C:\Proven File Attachments folder." _
        & vbCrLf & vbCrLf & "Would you like to view the files now?", vbQuestion + vbYesNo, "Finished!")
    If varResponse = vbYes Then
        Shell "Explorer.exe /e,C:\Proven File Attachments", vbNormalFocus
    End If
Else
    MsgBox "No files were found in your mail.", vbInformation, "Finished!"

End If


'Next


ExportAttachments_exit:
    Set atmt = Nothing
    Set item = Nothing
    Set ns = Nothing
    Exit Sub


ExportAttachments_err:
    MsgBox "An unexpected error has occurred." _
    & vbCrLf & "Please note and report the following information." _
    & vbCrLf & "Macro Name: ExportAttachments" _
    & vbCrLf & "Error Number: " & err.Number _
    & vbCrLf & "Error Description: " & err.description _
    , vbCritical, "Error!"
Resume ExportAttachments_exit
Exit Sub
End Sub


Sub iterFolder(subfolder As Object, intCount As Integer, str as string)
Dim atmt As Object
Dim fldr As Object
Dim item As Object
    str = str & subfolder.folderpath & vbCrLf
    For Each item In subfolder.Items
        For Each atmt In item.Attachments
            If Right(atmt.Filename, 3) = "csv" Or Right(atmt.Filename, 3) = "xls" Or Right(atmt.Filename, 4) = "xlsx" Or Right(atmt.Filename, 3) = "pdf" Then
                        Filename = "C:\Proven File Attachments\" & _
                    atmt.Filename & " - " & Format(item.ReceivedTime, "ddmmyyyy_hhnn")
                atmt.SaveAsFile Filename
                intCount = intCount + 1
            End If
        Next atmt
    Next item
    For Each fldr In subfolder.folders
       iterFolder fldr, intCount, str as string
    Next
End Sub

Open in new window

kwthomp

ASKER

It only returns the attachment in the named "subfolder", or the default message if it is empty. But it does not go through the rest of the subfolders within the "inbox" folder.

kwthomp

ASKER CERTIFIED SOLUTION

Chris Bottomley

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

kwthomp

ASKER

Brilliant. Thanks Chris, it worked.

kwthomp

Chris Bottomley

kwthomp

ASKER

Really appreciate the patience and time.....