Excel macro to get all mails of shared mailbox

[THE_NEW_XL_GUY]

Hi guys,

Need some assistance in the following code which I have (wrote, collected, edited and got help from fellow mrexcel members).
Current code gives me exact shared mailbox- inbox mails. I have tried including folders, If I do I get only mentioned folder mails.
No matter what I change I still get only specified sub folder mails if not specified I get only inbox mails.


Kindly help me in getting all the mails of a sharedmailbox folder ( including inbox, folders under inbox, subfolders under folders)

brief detais again:
Current code: gets me mails of only inbox of sharedmailbox

requirement: I need all the mails of sharedmailbox including inbox, folders and subfolders( all mails of sharedmailbox)

PS: I know this-by using folders.("name of the folder") will get required subfolder mails but I need all subfolders, uplevel folders and inbox mails of sharedmailbox only.

Advance thanks! really need this as I searched forum and others I haven't got anything related to this particular requirement.

Sub GetFromOutlook()
    Dim OutlookApp As Outlook.Application
    Dim OutlookNamespace As Outlook.Namespace
    Dim olShareName As Outlook.Recipient
    Dim Folder As MAPIFolder
    Dim olItems As Outlook.Items
    Dim OutlookMail As Variant
    Dim arrResults() As Variant
    Dim ItemCount As Long
    
    Set OutlookApp = New Outlook.Application
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    Set olShareName = OutlookNamespace.CreateRecipient("email@email.com")
    Set Folder = OutlookNamespace.GetSharedDefaultFolder(olShareName, olFolderInbox)
    Set olItems = Folder.Items.Restrict("[ReceivedTime] >= '" & Range("From_date").Value & "' and [ReceivedTime] <= '" & Range("to_date").Value & "'")
    
    If olItems.Count > 0 Then
        ReDim arrResults(1 To olItems.Count, 1 To 5)
        ItemCount = 0
        For Each OutlookMail In olItems
            ItemCount = ItemCount + 1
            arrResults(ItemCount, 1) = OutlookMail.Subject
            arrResults(ItemCount, 2) = OutlookMail.ReceivedTime
            arrResults(ItemCount, 3) = OutlookMail.SenderName
            arrResults(ItemCount, 4) = OutlookMail.Size
            arrResults(ItemCount, 5) = OutlookMail.Categories
        Next OutlookMail
        Worksheets("import").Range("A5").Resize(UBound(arrResults, 1), 5) = arrResults
    Else
        MsgBox "No items found!", vbExclamation
    End If
    
    Set olItems = Nothing
    Set Folder = Nothing
    Set OutlookNamespace = Nothing
    Set olShareName = Nothing
    Set OutlookApp = Nothing
End Sub

 

[THE_NEW_XL_GUY]

really appreciate the help.