Solved

Recursive list of attachements in outlook folders

Posted on 2014-01-31
11
244 Views
Last Modified: 2014-02-07
Experts, i am working on a little project where i need to search through the outlook folders and create the same folder structure in the users "My Documents" folder. Those folders will store the attachments in the users outlook folders and the attachment in the outlook folders will be deleted to keep from bloating our exchange.

I am no where near this point yet but i have some questions about the code i have been playing around with.

Currently in my testing and learning phase i am just writing the folder name, attachment file name, sent date, and file size to a text file.

First, while this does get all of my folder structure, it is not getting all of the file attachments. In the text file it writes out the name of the current folder and then lists all of the file attachments under it. Some folders that i know have hundreds of attachments are showing nothing in the text file.

Second, I do not seem to be able to go through the sent items folder.

Can you guys help me with these two issues please.

Private FF As Integer
Private totalSize As Long

Sub ProcessFolder(StartFolder As Outlook.MAPIFolder)
    Dim objFolder As Outlook.MAPIFolder
    Dim objItem As Object
    Dim mailItem As Outlook.mailItem
    Dim varLoop As Long
    On Error Resume Next
     
    'do something specific with this folder
    'Debug.Print StartFolder.FolderPath, StartFolder.Items.Count
    'Debug.Print
         
    ' process all the subfolders of this folder
    For Each objFolder In StartFolder.Folders
        Call ProcessFolder(objFolder)
        
        Print #FF, "********************************************************************************************"
        Print #FF, "FOLDER NAME: " & objFolder.Name
        Print #FF, "********************************************************************************************"
        
        Debug.Print objFolder.Name
        
        For Each mailItem In objFolder.Items
            
            If mailItem.Attachments.Count > 0 Then
                
                For varLoop = 0 To mailItem.Attachments.Count - 1
                    
                    totalSize = totalSize + CLng(mailItem.Attachments.Item(varLoop).Size)
                    
                    Print #FF, vbTab & mailItem.Attachments.Item(varLoop).FileName & ", " & mailItem.Attachments.Item(varLoop).Size & ", " & mailItem.SentOn
                    Debug.Print mailItem.Attachments.Item(varLoop).FileName
                    
                Next varLoop
                
            End If
            
        Next
                
    Next
     
    'process all the items in this folder
    'For Each objItem In StartFolder.Items
        
        'Call ProcessFolder(objItem)
    '    Debug.Print objItem
    'Next
     
    Set objFolder = Nothing
    
End Sub

Private Sub Command1_Click()

    Dim objNS As Outlook.NameSpace
    Dim MyFolder As Outlook.MAPIFolder
    On Error Resume Next
    
    Set objNS = Application.GetNamespace("MAPI")
    Set MyFolder = objNS.GetDefaultFolder(olFolderInbox)
    Call ProcessFolder(MyFolder)
    
    Set MyFolder = objNS.GetDefaultFolder(olFolderSentMail)
    Call ProcessFolder(MyFolder)
    
    Set objNS = Nothing
    Set MyFolder = Nothing
    
    Print #FF, "************************************************************************"
    Print #FF, "TOTAL ATTACHMENT FILE SIZE: " & Format(totalSize, "###,###,###") & " bytes"
    Print #FF, "************************************************************************"

End Sub

Private Sub Form_Load()
    
    FF = FreeFile
    
    Open "C:\Attachments.txt" For Append As #FF

End Sub

Private Sub Form_Unload(Cancel As Integer)

    Close #FF

End Sub

Open in new window

0
Comment
Question by:Basicfarmer
  • 5
  • 5
11 Comments
 
LVL 76

Expert Comment

by:David Lee
Comment Utility
Hi, Basicfarmer.

I'm a little confused.  The code looks like it was written in VB6, but it makes reference to the Application object which would only be available in a VBA module running inside of Outlook.  I need to know which it is in order to help out.
0
 
LVL 20

Expert Comment

by:ltlbearand3
Comment Utility
For some reason your attachment loop is missing getting MS Office documents.  I prefer a For Each loop and switched to that.  Give this code a try as I think it will get everything for you now.  Since your code already was hitting the sent folder, I don't know that I understand your problem there.

Private FF As Integer
Private totalSize As Long

Sub ProcessFolder(StartFolder As Outlook.MAPIFolder)
    Dim objFolder As Outlook.MAPIFolder
    Dim objItem As Object
    Dim mailItem As Outlook.mailItem
    Dim mailAttachment As Outlook.Attachment
    Dim varLoop As Long
    On Error Resume Next
     
    'do something specific with this folder
    'Debug.Print StartFolder.FolderPath, StartFolder.Items.Count
    'Debug.Print
         
    ' process all the subfolders of this folder
    For Each objFolder In StartFolder.Folders
        Call ProcessFolder(objFolder)
        
        Print #FF, "********************************************************************************************"
        Print #FF, "FOLDER NAME: " & objFolder.Name
        Print #FF, "********************************************************************************************"
        
        Debug.Print objFolder.Name
        
        For Each mailItem In objFolder.Items
            For Each mailAttachment In mailItem.Attachments
                totalSize = totalSize + CLng(mailAttachment.Size)
                Print #FF, vbTab & mailAttachment.FileName & ", " & mailAttachment.Size & ", " & mailItem.SentOn
                Debug.Print mailAttachment.FileName
            Next
        Next
                
    Next
     
    'process all the items in this folder
    'For Each objItem In StartFolder.Items
        
        'Call ProcessFolder(objItem)
    '    Debug.Print objItem
    'Next
     
    Set objFolder = Nothing
    
End Sub

Private Sub Command1_Click()

    Dim objNS As Outlook.NameSpace
    Dim MyFolder As Outlook.MAPIFolder
    On Error Resume Next
    
    Set objNS = Application.GetNamespace("MAPI")
    Set MyFolder = objNS.GetDefaultFolder(olFolderInbox)
    Call ProcessFolder(MyFolder)
    
    Set MyFolder = objNS.GetDefaultFolder(olFolderSentMail)
    Call ProcessFolder(MyFolder)
    
    Set objNS = Nothing
    Set MyFolder = Nothing
    
    Print #FF, "************************************************************************"
    Print #FF, "TOTAL ATTACHMENT FILE SIZE: " & Format(totalSize, "###,###,###") & " bytes"
    Print #FF, "************************************************************************"

End Sub

Private Sub Form_Load()
    
    FF = FreeFile
    
    Open "C:\Attachments.txt" For Append As #FF

End Sub

Private Sub Form_Unload(Cancel As Integer)

    Close #FF

End Sub
                                  

Open in new window

0
 

Author Comment

by:Basicfarmer
Comment Utility
BlueDevilFan, i am confused as well as to what you are telling me. I put this together in reading from posts i found here. I have set a reference in my project to the Microsoft Outlook 14.0 Object Library. When i type "application." intellisence gives me options. Am I doint something wrong here.

Screen Shot
ltlbearand3, something is still missing. I have attached the output file from the recursive search. If you look at the files that are stored in the "North Central" folder, it has found only a few attachments. But in that folder there are actually hundreds of attachments. For some reason this is not finding all attachments. Also, it does not seem to find the sent items folder.
Attachments.txt
0
 
LVL 20

Expert Comment

by:ltlbearand3
Comment Utility
I need some more information, but will try to take some guesses here.  You might post what version of outlook you are using.  When I run my adaptation of your code it gets all attachments and hits all sub folders under Inbox and Sent Items.  Do you want this to also grab the parent Inbox and Sent Items folders?  If so, try the code below.  The other thing to look at is that your code is only scanning the mailbox and not any personal folders.  Could that be the problem.  Maybe try this code:

Private FF As Integer
Private totalSize As Long

Sub ProcessFolder(StartFolder As Outlook.MAPIFolder)
    Dim objFolder As Outlook.MAPIFolder
    Dim mailItem As Outlook.mailItem
    Dim mailAttachment As Outlook.Attachment
    'On Error Resume Next
     
    ' Get all the Attachments in this folder
    Debug.Print StartFolder.Name
    
    Print #FF, "********************************************************************************************"
    Print #FF, "FOLDER NAME: " & objFolder.Name
    Print #FF, "********************************************************************************************"
        
    For Each mailItem In StartFolder.Items
        Debug.Print mailItem.Subject
        For Each mailAttachment In mailItem.Attachments
            totalSize = totalSize + CLng(mailAttachment.Size)
            Print #FF, vbTab & mailAttachment.FileName & ", " & mailAttachment.Size & ", " & mailItem.SentOn
            Debug.Print mailAttachment.FileName
        Next
    Next
     
    ' Now loop through any subfolders that happen to exist
    For Each objFolder In StartFolder.Folders
        Call ProcessFolder(objFolder)
    Next
     
    Set objFolder = Nothing
    Set mailItem = Nothing
    Set mailAttachment = Nothing
    
End Sub

Private Sub Command1_Click()

    Dim objNS As Outlook.NameSpace
    Dim MyFolder As Outlook.MAPIFolder
    On Error Resume Next
    
    Set objNS = Application.GetNamespace("MAPI")
    Set MyFolder = objNS.GetDefaultFolder(olFolderInbox)
    Call ProcessFolder(MyFolder)
    
    Set MyFolder = objNS.GetDefaultFolder(olFolderSentMail)
    Call ProcessFolder(MyFolder)
    
    Set objNS = Nothing
    Set MyFolder = Nothing
    
    Print #FF, "************************************************************************"
    Print #FF, "TOTAL ATTACHMENT FILE SIZE: " & Format(totalSize, "###,###,###") & " bytes"
    Print #FF, "************************************************************************"

End Sub

Private Sub Form_Load()
    
    FF = FreeFile
    
    Open "C:\Attachments.txt" For Append As #FF

End Sub

Private Sub Form_Unload(Cancel As Integer)

    Close #FF

End Sub

Open in new window

0
 

Author Comment

by:Basicfarmer
Comment Utility
I copy and pasted the above code and all it did was print "inbox" and "sent items" in the deug window. It also only listed those items in the output text file. So i went back to the code in your first post and changed;

Set MyFolder = objNS.GetDefaultFolder(olFolderInbox)

To:

Set MyFolder = objNS.GetDefaultFolder(olFolderInbox).Parent

This showed all folders in the output textfile even the sent items, but it never went into the sent items folder or it did not find anything there.

I also still is not picking up all attachments.

I didnt know it if made any difference so i did not mention previously that this is using exchange. i dont know what difference it would make because i thought it was storing everything on my pc. But maybe it has something to do with it.
0
Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

 
LVL 20

Expert Comment

by:ltlbearand3
Comment Utility
Sorry, I took out your On Error Resume Next as I figured that can cause problems when stuff is missing and forgot to add an error handler back in.  You probably have some "attachments" that do not have file names.  It also made me think that we should skip any imbedded images - though you may want those.  However, anyone who uses an imbedded graphic in their signature line shows up as an imbedded attachment.  The best code for checking that is some that BlueDevilFan has posted here before (don't remember which question sorry BlueDevilFan).  However, I have added it in here.  Give this code a try:

Private FF As Integer
Private totalSize As Long

Sub ProcessFolder(StartFolder As Outlook.MAPIFolder)
    On Error GoTo ErrHandler

    Dim objFolder As Outlook.MAPIFolder
    Dim mailItem As Object ' Outlook.mailItem
    Dim mailAttachment As Outlook.Attachment
    'On Error Resume Next
     
    ' Get all the Attachments in this folder
    Debug.Print StartFolder.Name
    
    Print #FF, "********************************************************************************************"
    Print #FF, "FOLDER NAME: " & objFolder.Name
    Print #FF, "********************************************************************************************"
        
    For Each mailItem In StartFolder.Items
        For Each mailAttachment In mailItem.Attachments
            If Not IsEmbedded(mailAttachment) Then
                totalSize = totalSize + CLng(mailAttachment.Size)
               Print #FF, vbTab & mailAttachment.FileName & ", " & mailAttachment.Size & ", " & mailItem.SentOn
                Debug.Print "Attach=" & mailAttachment.FileName
            End If
        Next
    Next
    
    ' Now loop through any subfolders that happen to exist
    For Each objFolder In StartFolder.Folders
        Call ProcessFolder(objFolder)
    Next
     
    Set objFolder = Nothing
    Set mailItem = Nothing
    Set mailAttachment = Nothing
    
ErrHandler:
    MsgBox "Error Processing Attachments" & vbCrLf & Err.Number & ":" & Err.Description
End Sub

Private Sub Command1_Click()

    Dim objNS As Outlook.NameSpace
    Dim MyFolder As Outlook.MAPIFolder
    On Error Resume Next
    
    Set objNS = Application.GetNamespace("MAPI")
    Set MyFolder = objNS.GetDefaultFolder(olFolderInbox)
    Call ProcessFolder(MyFolder)
    
    Set MyFolder = objNS.GetDefaultFolder(olFolderSentMail)
    Call ProcessFolder(MyFolder)
    
    Set objNS = Nothing
    Set MyFolder = Nothing
    
    Print #FF, "************************************************************************"
    Print #FF, "TOTAL ATTACHMENT FILE SIZE: " & Format(totalSize, "###,###,###") & " bytes"
    Print #FF, "************************************************************************"

End Sub

Private Sub Form_Load()
    
    FF = FreeFile
    
    Open "C:\Attachments.txt" For Append As #FF

End Sub

Private Sub Form_Unload(Cancel As Integer)

    Close #FF

End Sub
                                  

Function IsEmbedded(olkAttachment As Outlook.Attachment) As Boolean
    'Purpose: Determines if an attachment is embedded.'
    'Written: 9/14/2009'
    'Author: BlueDevilFan'
    'Outlook: 2007'
    Dim olkPA As Outlook.PropertyAccessor
    Set olkPA = olkAttachment.PropertyAccessor
    On Error Resume Next
    IsEmbedded = (olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001E") <> "")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

Open in new window


If this does not work, I suggest posting a screen shot of the folder structure in your outlook.  You can use MSPaint or some other tool to blackout the sensitive information.  That way I can see how your folder structure is set up.  If you cannot post that and are still having troubles, let us know.  I can then walk you through some more detailed steps on how to tell us exactly your set up.
0
 

Author Comment

by:Basicfarmer
Comment Utility
This certainly did weed out the pictures people have in their signatures.

I ran into a ton of errors. Do you know what is causing them. I guess i wasnt seeing them before because of the resume next. Could that be why it seems i am missing some attachments?

I dont get it, some of the folders that were missing attachments now showed all of the attachments. Then on the other hand, folders that were previously displaying all attachments are now showing nothing.

It must be something about the mail system that i dont understand.
0
 
LVL 20

Accepted Solution

by:
ltlbearand3 earned 500 total points
Comment Utility
I thought I had run the code through several loops with the error handling, but obviously not - sorry.  I missed a line of code that is causing some of your problems.  However, it made me think that we should track the errors even better to see if something else is causing the problem.  I also found one other thing to check that might be causing some errors.  Give this code a try.  If you do get an error, please post the error message that prints in the immediate window.  
Private FF As Integer
Private totalSize As Long

Sub ProcessFolder(StartFolder As Outlook.MAPIFolder)
    On Error GoTo ErrHandler

    Dim objFolder As Outlook.MAPIFolder
    Dim mailItem As Object
    'Dim mailItem As Outlook.mailItem
    Dim mailAttachment As Outlook.Attachment
         
    ' Get all the Attachments in this folder
110    Debug.Print StartFolder.Name
    
120    Print #FF, "********************************************************************************************"
130    Print #FF, "FOLDER NAME: " & objFolder.Name
140    Print #FF, "********************************************************************************************"
        
150    For Each mailItem In StartFolder.Items
160        For Each mailAttachment In mailItem.Attachments
170            If Not IsEmbedded(mailAttachment) And mailAttachment.Type <> olOLE Then
180                totalSize = totalSize + CLng(mailAttachment.Size)
190               Print #FF, vbTab & mailAttachment.FileName & ", " & mailAttachment.Size & ", " & mailItem.SentOn
200                Debug.Print "Attach=" & mailAttachment.FileName
210            End If
220        Next
230    Next
    
    ' Now loop through any subfolders that happen to exist
240    For Each objFolder In StartFolder.Folders
250        Call ProcessFolder(objFolder)
260    Next
     
    Set objFolder = Nothing
    Set mailItem = Nothing
    Set mailAttachment = Nothing
    
    Exit Sub
    
ErrHandler:
    MsgBox "Error Processing Attachments" & vbCrLf & Err.Number & ":" & Err.Description
    Debug.Print "**Error On Line " & Erl & ".  #" & Err.Number & ":" & Err.Description
End Sub

Private Sub Command1_Click()

    Dim objNS As Outlook.NameSpace
    Dim MyFolder As Outlook.MAPIFolder
    On Error Resume Next
    
    Set objNS = Application.GetNamespace("MAPI")
    Set MyFolder = objNS.GetDefaultFolder(olFolderInbox)
    Call ProcessFolder(MyFolder)
    
    Set MyFolder = objNS.GetDefaultFolder(olFolderSentMail)
    Call ProcessFolder(MyFolder)
    
    Set objNS = Nothing
    Set MyFolder = Nothing
    
    Print #FF, "************************************************************************"
    Print #FF, "TOTAL ATTACHMENT FILE SIZE: " & Format(totalSize, "###,###,###") & " bytes"
    Print #FF, "************************************************************************"

End Sub

Private Sub Form_Load()
    
    FF = FreeFile
    
    Open "C:\Attachments.txt" For Append As #FF

End Sub

Private Sub Form_Unload(Cancel As Integer)

    Close #FF

End Sub
                                  

Function IsEmbedded(olkAttachment As Outlook.Attachment) As Boolean
    'Purpose: Determines if an attachment is embedded.'
    'Written: 9/14/2009'
    'Author: BlueDevilFan'
    'Outlook: 2007'
    Dim olkPA As Outlook.PropertyAccessor
    Set olkPA = olkAttachment.PropertyAccessor
    On Error Resume Next
    IsEmbedded = (olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001E") <> "")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

Open in new window

0
 

Author Comment

by:Basicfarmer
Comment Utility
The object objFolder no longer refers to anything and is nothing. So i keep getting these errors. Im not sure where to put this now to output the current folder name.

Inbox
**Error On Line 130.  #91:Object variable or With block variable not set
Sent Items
**Error On Line 130.  #91:Object variable or With block variable not set
Inbox
**Error On Line 130.  #91:Object variable or With block variable not set
Sent Items
**Error On Line 130.  #91:Object variable or With block variable not set
0
 
LVL 20

Expert Comment

by:ltlbearand3
Comment Utility
Sorry.  I had that line commented out for my testing.  That should be StartFolder.Name
0
 

Author Closing Comment

by:Basicfarmer
Comment Utility
Thanks for all the help. It is working very well. Now i can move on with the project.
0

Featured Post

What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

Suggested Solutions

Title # Comments Views Activity
Problem to skip loop 6 48
noX challenge 17 75
Visual Basic Excel Formatting error 4 66
Protecting vb6 & .Net code Obfuscation 18 43
Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
Go is an acronym of golang, is a programming language developed Google in 2007. Go is a new language that is mostly in the C family, with significant input from Pascal/Modula/Oberon family. Hence Go arisen as low-level language with fast compilation…
This video teaches viewers about errors in exception handling.
The viewer will learn how to clear a vector as well as how to detect empty vectors in C++.

763 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

6 Experts available now in Live!

Get 1:1 Help Now