Reference a subfolder of Inbox

Question

I want to extract text, from emails in an Outlook Folder named "FaxReceipt", to an Excel spreadsheet

I have created a column name "FaxReceipt". I want all text extracted into the Excel column.

Sub OutlookEMails1()
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim myitem As Outlook.MailItem
Dim FileName As String
Dim i As Integer
Dim objSearchFolder As Outlook.MAPIFolder
Dim item As Object
Dim mai As MailItem

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set objSearchFolder = Inbox
i = 0
If Inbox.Items.Count = 0 Then
    MsgBox "Inbox is Empty", vbInformation, "Nothing Found"
End If

For Each item In Inbox.Items
    vbody = item.Body
    Range("A2").Select

    Do Until ActiveCell.Value = ""
        ActiveCell.Offset(1).Select
    Loop
    ActiveCell.Value = vbody
Next

Set objSearchFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing

End Sub

This code is only working on the default Inbox folder.

score 1 · Answer 1 · answered Jul 21 '17 at 10:23

You just need to alter your code to:

A. Set an object to the subfolder of Inbox (you already have a objSearchFolder - you just weren't using it.)

B. Look in that object instead of Inbox

Sub OutlookEMails1()
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim myitem As Outlook.MailItem
Dim FileName As String
Dim i As Integer
Dim objSearchFolder As Outlook.MAPIFolder
Dim item As Object
Dim mai As MailItem

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set objSearchFolder = Inbox.Folders("faxreceipt")
i = 0

If objSearchFolder.Items.Count = 0 Then
    MsgBox "Search Folder is Empty", vbInformation, "Nothing Found"
End If

For Each item In objSearchFolder.Items
    vbody = item.Body
    Range("A2").Select

    Do Until ActiveCell.Value = ""
        ActiveCell.Offset(1).Select
    Loop
    ActiveCell.Value = vbody
Next

Set objSearchFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing

End Sub

Glad I could help. If you're happy that we've answered your question then don't forget to mark one of the responses as the answer. — CLR, Jul 24 '17 at 11:24

score 0 · Answer 2 · answered Jul 21 '17 at 10:20

Try this:

Sub OutlookEMails1()

Dim ns                  As Namespace
Dim Inbox               As MAPIFolder
Dim myitem              As Outlook.MailItem
Dim FileName            As String
Dim i                   As Integer
Dim objSearchFolder     As Outlook.MAPIFolder
Dim item                As Object
Dim mai                 As MailItem
Dim objFaxReceiptFolder As Object

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set objSearchFolder = Inbox
Set objFaxReceiptFolder = Inbox.Folders("faxreceipt")
i = 0
If objFaxReceiptFolder.Items.Count = 0 Then
    MsgBox "Folder Fax Receipt is Empty", vbInformation, "Nothing Found"
End If
For Each item In objFaxReceiptFolder.Items
    vbody = item.Body
Range("A2").Select

Do Until ActiveCell.Value = ""
    ActiveCell.Offset(1).Select
Loop
    ActiveCell.Value = vbody
Next
Set objSearchFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing

End Sub

Reference a subfolder of Inbox

2 Answers2