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

kwthompAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Chris BottomleySoftware Quality Lead EngineerCommented:
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

0
Chris BottomleySoftware Quality Lead EngineerCommented:
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

0
Chris BottomleySoftware Quality Lead EngineerCommented:
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
0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

Chris BottomleySoftware Quality Lead EngineerCommented:
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

0
kwthompAuthor Commented:
Thanks chris.
But It appears to focus only on the named subfolder, and does not loop through the rest of the folders.
0
Chris BottomleySoftware Quality Lead EngineerCommented:
Let me scale up a test before I respond

Chris
0
Chris BottomleySoftware Quality Lead EngineerCommented:
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
0
Chris BottomleySoftware Quality Lead EngineerCommented:
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

0
kwthompAuthor Commented:
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
0
Chris BottomleySoftware Quality Lead EngineerCommented:
>>> But it does not go through the rest of the subfolders within the "inbox" folder

Correct your code used teh following and so did I

Set Inbox = ns.Folders("Personal Folders").Folders("Freezone")
Set SubFolder = Inbox.Folders("Free 1")

I have modified the earlier code to mode off the inbox 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 = Application.Session.GetDefaultFolder(olFolderInbox)
'Set SubFolder = Inbox.Folders("Free 1")
i = 0

'For Each SubFolder In Inbox.Items


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


If inbox.Items.count > 0 Then
   iterFolder inbox, 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

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
kwthompAuthor Commented:
Brilliant. Thanks Chris, it worked.

kwthomp
0
Chris BottomleySoftware Quality Lead EngineerCommented:
:)
0
kwthompAuthor Commented:
Really appreciate the patience and time.....
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.