How to import email from a shared mailbox subfolder too, and mark the foldername in Excel

Question

I have the following macro, where I'm importing emails from outlook. The macro only imports the emails from the Inbox folder,

I would like the macro to go through al the subfolders of Inbox Folder (so no Sent items, etc, but the sub folders of the Inbox folder only).

Sub GetFromOutlook()

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim objMail As Outlook.MailItem
Dim objFlaggedMail As Outlook.MailItem

Application.ScreenUpdating = False

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")

Set olShareName = OutlookNamespace.CreateRecipient("shared_mailbox_name")
Set Folder = OutlookNamespace.GetSharedDefaultFolder(olShareName, olFolderInbox)

Range("A:I").ClearContents

Range("A3").Value = "Subject"
Range("B3").Value = "Date"
Range("C3").Value = "Sender"
Range("D3").Value = "Category"
Range("E3").Value = "Mailbox"
i = 4

On Error Resume Next
For Each OutlookMail In Folder.Items

    Range("A" & i).Value = OutlookMail.Subject
    Range("B" & i).Value = OutlookMail.ReceivedTime
    Range("C" & i).Value = OutlookMail.SenderName
    Range("D" & i).Value = OutlookMail.Categories
    Range("E" & i).Value = OutlookMail.Folder

and in the E column, I would like if the name of the folder it took the email from would-be written...

So it is already okay with other columns, however in this way, I would like if it is copied from Inbox folder then in E column it will write Inbox, but if it is copied from Subfolder1 then it will write SUbfolder1 and etc...

How should I approach this?

Answer 1

Try the following

Option Explicit
Private Sub Example()
    Dim olApp As outlook.Application
    Set olApp = New outlook.Application

    Dim olNs As outlook.Namespace
    Set olNs = olApp.GetNamespace("MAPI")

    Dim olRecip As outlook.Recipient
    Set olRecip = olNs.CreateRecipient("0m3r@EmailAddress.com") ' Update email

    Dim Inbox As outlook.MAPIFolder
    Set Inbox = olNs.GetSharedDefaultFolder(olRecip, olFolderInbox)

    Dim Sht As Worksheet
    Set Sht = ThisWorkbook.Sheets("Sheet1")

    With Sht
        .Range("A3").Value = "Subject"
        .Range("B3").Value = "Date"
        .Range("C3").Value = "Sender"
        .Range("D3").Value = "Category"
        .Range("E3").Value = "Mailbox"
    End With

'   // Process Current Folder
    LoopFolders Inbox, Sht

End Sub

Private Sub LoopFolders( _
    ByVal CurrentFolder As outlook.MAPIFolder, _
    ByVal Sht As Worksheet _
)

    Dim Items As outlook.Items
    Set Items = CurrentFolder.Items

    Dim i As Long
    Dim last_row As Long
    Dim Item As Object ' Outlook.MailItem

    With Sht
        last_row = Sht.Range("A" & .Rows.Count).End(xlUp).Row + 1

        For i = Items.Count To 1 Step -1 ' run loop
            Set Item = Items(i)
            DoEvents
            If TypeOf Item Is outlook.MailItem Then

                 Debug.Print Item
                .Range("A" & last_row).Value = Item.Subject
                .Range("B" & last_row).Value = Item.ReceivedTime
                .Range("C" & last_row).Value = Item.SenderName
                .Range("D" & last_row).Value = Item.Categories
                .Range("E" & last_row).Value = CurrentFolder.Name

            End If

            last_row = last_row + 1

        Next

    '   // Recurse through subfolders
        Dim folder As outlook.MAPIFolder
        If CurrentFolder.Folders.Count > 0 Then
            For Each folder In CurrentFolder.Folders
                LoopFolders folder, Sht
            Next
        End If

    End With

'   // Cleanup
    Set folder = Nothing
    Set Item = Nothing
    Set Items = Nothing
End Sub