Outlook to Excel Macro: How do I specify a specific outlook folder to pull from in this code?

[Hawk11ns]

I posed a question earlier but have found what seems to work Here. However, it pulls ALL of my email items whereas I only wish to pull items in my inbox. What portion of code should be modified to achieve this?

Option Explicit 
Dim RootFolder As String
Dim OlApp As Outlook.Application
Dim oMAPI As Outlook.Namespace
Dim oParentFolder As Outlook.MAPIFolder
Dim ws As Worksheet
Dim intTotalItems As Long
Dim intRowPointer As Long
 
Public Sub GetOutlookMail()
 
 Dim dteTimer As Date
 
 RootFolder = ("Mailbox - SURNAME, Forename")
 
 dteTimer = Now()
 
 Set ws = ThisWorkbook.Sheets("Sheet1")
 Set OlApp = CreateObject("Outlook.Application")
 Set oMAPI = GetObject("", "Outlook.application").GetNamespace("MAPI")
 Set oParentFolder = oMAPI.Folders(RootFolder)
 
 intTotalItems = 0
 Call CountAllItems(oParentFolder)
 ws.Columns("A:S").ClearContents
 
 Call ColumnHeaders
 
 intRowPointer = 2
 Application.Cursor = xlWait
 Call ProcessFolder(oParentFolder)
 Application.Cursor = xlDefault
 
 MsgBox "Done: " & CStr(intTotalItems) & " items (" & Format(dteTimer - Now(), "hh:nn:ss") & ")"
 
 Set OlApp = Nothing
 
End Sub
 
Private Sub CountAllItems(StartFolder As Outlook.MAPIFolder)
 
 Dim uFolder As Outlook.MAPIFolder
 Dim MailObject As Object
 
 If StartFolder.DefaultItemType = 0 And StartFolder.FolderPath <> "\\" & RootFolder Then
     intTotalItems = intTotalItems + StartFolder.Items.Count
 End If
 If StartFolder.DefaultItemType = 0 Then
   For Each uFolder In StartFolder.Folders
     Call CountAllItems(uFolder)
   Next uFolder
 End If
 
 Set uFolder = 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
     Call ProcessFolder(uFolder)
   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
 
 For Each MailObject In Collection
   DoEvents
   If TypeOf MailObject Is MailItem Then
     ws.Cells(intRowPointer, 1) = MailObject.SentOn
     ws.Cells(intRowPointer, 2) = MailObject.SenderName
     ws.Cells(intRowPointer, 3) = MailObject.SenderEmailAddress
     ws.Cells(intRowPointer, 4) = MailObject.SentOnBehalfOfName
     ws.Cells(intRowPointer, 5) = MailObject.To
     ws.Cells(intRowPointer, 6) = MailObject.CC
     ws.Cells(intRowPointer, 7) = MailObject.BCC
     ws.Cells(intRowPointer, 8) = MailObject.ReceivedByName
     ws.Cells(intRowPointer, 9) = MailObject.ReceivedOnBehalfOfName
     ws.Cells(intRowPointer, 10) = MailObject.ReplyRecipientNames
     ws.Cells(intRowPointer, 11) = MailObject.Subject
     ws.Cells(intRowPointer, 16) = ""
     For intAttachment = 1 To MailObject.Attachments.Count
       ws.Cells(intRowPointer, 16) = ws.Cells(intRowPointer, 16) & ";" & MailObject.Attachments(intAttachment).Filename
       ' we may want to save some or all of the attachments
       ' MailObject.Attachments(intAttachment).SaveAsFile "C:\Temp\" & MailObject.Attachments(intAttachment).FileName
     Next intAttachment
     ws.Cells(intRowPointer, 16) = Mid(ws.Cells(intRowPointer, 16), 2) ' remove leading semicolon
     ws.Cells(intRowPointer, 17) = CurrentFolder.FolderPath
     ws.Cells(intRowPointer, 18) = CurrentFolder.Name
     If MailObject.UnRead Then
       ws.Cells(intRowPointer, 19) = "N"
     Else
       ws.Cells(intRowPointer, 19) = "Y"
     End If
     intRowPointer = intRowPointer + 1
   End If
 Next MailObject
 
 Set MailObject = Nothing
 
End Sub
 
Private Sub ColumnHeaders()
 
 Dim ColumnHeads As Variant
 
 ColumnHeads = Array("SenderName", "SenderEmailAddress", "SentOnBehalfOfName", "To", "CC", _
       "BCC", "ReceivedByName", "ReceivedOnBehalfOfName", "ReplyRecipientNames", "Subject", _
       "SentOn", "Body", "HTMLBody", "Importance", "AttachmentsCount", "Attachments", _
       "FolderPath", "FolderName", "Read")
 
 ws.Range("A1").Resize(1, UBound(ColumnHeads) + 1) = ColumnHeads
 Rows("2").Select
 With ActiveWindow
   .SplitColumn = 0
   .SplitRow = 1
 End With
 ActiveWindow.FreezePanes = True
 
 ws.Rows("1").Font.Bold = True
 
End Sub

 

[RickXL]

Hi,

The macro that needs changing is this one:

Public Sub GetOutlookMail()
 
    Dim dteTimer As Date
    
    RootFolder = ("Mailbox - SURNAME, Forename")
    
    dteTimer = Now()
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set OlApp = CreateObject("Outlook.Application")
    Set oMAPI = GetObject("", "Outlook.application").GetNamespace("MAPI")
    Set oParentFolder = oMAPI.GetDefaultFolder(olFolderInbox)
    
    intTotalItems = 0
    Call CountAllItems(oParentFolder)
    ws.Columns("A:S").ClearContents
    
    Call ColumnHeaders
    
    intRowPointer = 2
    Application.Cursor = xlWait
    Call ProcessFolder(oParentFolder)
    Application.Cursor = xlDefault
    
    MsgBox "Done: " & CStr(intTotalItems) & " items (" & Format(dteTimer - Now(), "hh:nn:ss") & ")"
    
    Set OlApp = Nothing
 
End Sub