• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1397
  • Last Modified:

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

0
kwthomp
Asked:
kwthomp
  • 9
  • 4
1 Solution
 
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
Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

 
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
 
kwthompAuthor Commented:
Brilliant. Thanks Chris, it worked.

kwthomp
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
:)
0
 
kwthompAuthor Commented:
Really appreciate the patience and time.....
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Cloud Class® Course: Ruby Fundamentals

This course will introduce you to Ruby, as well as teach you about classes, methods, variables, data structures, loops, enumerable methods, and finishing touches.

  • 9
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now