Is it possible to loop through a folder in Outlook using VBA?

SlinkRN

SlinkRN

Well-known Member
Joined
Oct 29, 2002
Messages
715
Hi,
I have some VBA that loops through a folder on my drive in order to open each file and copy a portion into a master file. I am wondering if I could loop through a folder that is in my Outlook Cabinet folder? In other words, rather than opening the emails every day and saving the file into a folder on my drive, I would just loop through the email attachments from all the emails in my "July 2012" folder in my Outlook cabinet, open the attachment and save from there at the end of July. Is the Outlook cabinet folder actually a pathway on my computer? When I look at the properties I just get "\\Mailbox - MyName\Cabinet\July 2012". Just wondering if I can save myself more time?? Thanks, Slink
 

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
Sort by date Sort by votes
Code: 
Option Explicit
Option Compare Text
 
Dim RootFolder As String
Dim OlApp As Outlook.Application
Dim oMAPI As Outlook.Namespace
Dim oParentFolder As Outlook.MAPIFolder
Dim SingleFolderRequired As String
Dim RecurseThroughSingleFolder As Boolean
Dim SingleFolderFound As Boolean
 
Public Sub GetOutlookAttachments()

'''''''''''''''''''''''''''''''''''''''''
'Set reference to Outlook object library'
'''''''''''''''''''''''''''''''''''''''''

'RootFolder: your Outlook root folder (mailbox name)

'SingleFolderRequired: set to blank if you want all mail to be retrieved (always recurses through subfolders); _
    or set to the full path of the folder you want to retrieve the mail from _
        (recurses through subfolders depending on the value of RecurseThroughSingleFolder)

'RecurseThroughSingleFolder: set to True if you want all subfolders scanned; _
                             set to False if you only want the actual folder scanned
  
  RootFolder = "Personal Folders"
  SingleFolderRequired = "\\Personal Folders\Test Emails" 'change to suit
  RecurseThroughSingleFolder = True
  
  Set OlApp = CreateObject("Outlook.Application")
  Set oMAPI = GetObject("", "Outlook.application").GetNamespace("MAPI")
  Set oParentFolder = oMAPI.Folders(RootFolder)
  SingleFolderFound = False
  Call ProcessFolder(oParentFolder)
  Set OlApp = Nothing
End Sub
 
Private Sub ProcessFolder(StartFolder As Outlook.MAPIFolder)
  Dim uFolder As Outlook.MAPIFolder
  If StartFolder.DefaultItemType = 0 Then
    Call ProcessItems(StartFolder, StartFolder.Items)
    For Each uFolder In StartFolder.Folders
      If SingleFolderFound = False Or RecurseThroughSingleFolder = True Then
        Call ProcessFolder(uFolder)
      End If
    Next uFolder
  End If
  Set uFolder = Nothing
End Sub
 
Private Sub ProcessItems(CurrentFolder As Outlook.MAPIFolder, Collection As Outlook.Items)
  Dim MailObject As Object
  Dim intAttachment As Integer
  If Len(SingleFolderRequired) > 0 Then
    If Left(CurrentFolder.FolderPath, Len(SingleFolderRequired)) = SingleFolderRequired Then
      SingleFolderFound = True
    Else
      Exit Sub
    End If
  End If
  For Each MailObject In Collection
    DoEvents
    If TypeOf MailObject Is MailItem Then
      'If DateValue(MailObject.SentOn) = DateValue("10/07/2012") Then 'could filter emails here
        For intAttachment = 1 To MailObject.Attachments.Count
          On Error Resume Next ' trap unknown attachment types
          MailObject.Attachments(intAttachment).SaveAsFile "C:\XLtest\" & MailObject.Attachments(intAttachment).Filename 'change path to suit
          On Error GoTo 0
        Next intAttachment
      'End If
    End If
  Next MailObject
  Set MailObject = Nothing
End Sub
 
Upvote 0
Thanks Warship!! I can't wait to try this tomorrow at work - I'll let you know how it goes!!! Slink
 
Upvote 0
Hi Warship, Today was crazy so I didn't get to test it until now. I've been playing with it for about an hour now and it seems to be looping through my Outlook folders so that is encouraging (and awesome!) but it never gets to the DoEvents part. Here is what I adapted so far:

Code: 
Option Explicit
Option Compare Text
 
Dim RootFolder As String
Dim OlApp As Outlook.Application
Dim oMAPI As Outlook.Namespace
Dim oParentFolder As Outlook.MAPIFolder
Dim SingleFolderRequired As String
Dim RecurseThroughSingleFolder As Boolean
Dim SingleFolderFound As Boolean
 
Public Sub GetOutlookAttachments()

'''''''''''''''''''''''''''''''''''''''''
'Set reference to Outlook object library'
'''''''''''''''''''''''''''''''''''''''''

'RootFolder: your Outlook root folder (mailbox name)

'SingleFolderRequired: set to blank if you want all mail to be retrieved (always recurses through subfolders); _
    or set to the full path of the folder you want to retrieve the mail from _
        (recurses through subfolders depending on the value of RecurseThroughSingleFolder)

'RecurseThroughSingleFolder: set to True if you want all subfolders scanned; _
                             set to False if you only want the actual folder scanned
  
  RootFolder = "Mailbox - My Name" 'I put my actual name here of course
  SingleFolderRequired = "\\Cabinet\TestFolder" 
  RecurseThroughSingleFolder = False ' I only want the emails in one folder for now although I tried it both as true and false
  
  Set OlApp = CreateObject("Outlook.Application")
  Set oMAPI = GetObject("", "Outlook.application").GetNamespace("MAPI")
  Set oParentFolder = oMAPI.Folders(RootFolder)
  SingleFolderFound = False
  Call ProcessFolder(oParentFolder)
  Set OlApp = Nothing
End Sub
 
Private Sub ProcessFolder(StartFolder As Outlook.MAPIFolder)
  Dim uFolder As Outlook.MAPIFolder
  If StartFolder.DefaultItemType = 0 Then
    Call ProcessItems(StartFolder, StartFolder.Items)
    For Each uFolder In StartFolder.Folders
      If SingleFolderFound = False Or RecurseThroughSingleFolder = True Then
        Call ProcessFolder(uFolder)
      End If
    Next uFolder
  End If
  Set uFolder = Nothing
End Sub
 
Private Sub ProcessItems(CurrentFolder As Outlook.MAPIFolder, Collection As Outlook.Items)
  Dim MailObject As Object
  Dim intAttachment As Integer
  If Len(SingleFolderRequired) > 0 Then
    If Left(CurrentFolder.FolderPath, Len(SingleFolderRequired)) = SingleFolderRequired Then
      SingleFolderFound = True
    Else
      Exit Sub
    End If
  End If
  For Each MailObject In Collection
    DoEvents
    If TypeOf MailObject Is MailItem Then
      'If DateValue(MailObject.SentOn) = DateValue("10/07/2012") Then 'I don't need to filter by date
        For intAttachment = 1 To MailObject.Attachments.Count
          On Error Resume Next ' trap unknown attachment types
          MailObject.Attachments(intAttachment).SaveAsFile "C:\Documents and Settings\mynamehere\desktop\XLtest\" & MailObject.Attachments(intAttachment).Filename 'change path to suit
          On Error GoTo 0
        Next intAttachment
      'End If
    End If
  Next MailObject
  Set MailObject = Nothing
End Sub
 
Last edited:
Upvote 0
Try changing this line, needs to be full path:
Code: 
SingleFolderRequired = "\\Mailbox - My Name\Cabinet\TestFolder"
 
Upvote 0
Thanks so much Warship!!! You are a genius!!!! Works like a charm :) I had to add a number to the filename since all of the attachments have the same name and were copying over each other but now it is working just as I imagined it could!! This will save me from doing this manually constantly :) If my workload ever calms down, I am looking forward to going through your code more completely to see exactly what each piece is doing!!! I understand a lot of it but there is no way I could have come up with that!!! Thanks so much for sharing your knowledge!!!! Slink
 
Upvote 0
Should've thought to warn you on the file over-write. :(

~~~~~~~~~~~

You could also take it to the next level by adding a Scheduled Task through Windows.
The task would launch your spreadsheet at a predetermined day/time which would then start the process via the Workbook_Open event.

It would all be done and waiting for you before you sat down with your first cup-o-jo.
I have a few "dailies" always waiting for me - it's great.
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question
Importing Outlook Data
Replies
0
Views
439
Legacy 512328
L
J
  • Question
Open Outlook
Replies
1
Views
198
Trevor G
Trevor G
J
  • Question
Parse HTML table or extract Outlook body items to excel sheet
Replies
2
Views
282
Jaffirahamed
J
L
  • Question
VBA query - not opening outlook email but one drive
Replies
0
Views
221
Liverlee
L
M
  • Question
Extract data from outlook emails using excel vba
Replies
1
Views
1K
RoryA
RoryA

Forum statistics

Threads
1,216,500
Messages
6,131,016
Members
449,615
Latest member
Nic0la

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top