Extract emails from multiple shared mailboxes

Question

I created a tool in Excel that will extract emails from a particular mailbox.

Sub GetFromOutlook()
    Dim OutlookApp as Outlook.Application
    Dim OutlookNameSpace As Namespace
    Dim Folder as MAPIfolder
    Dim OutlookMail As Variant
    Dim objowner As Variant
    Dim i as Integer

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

    Set objowner = OutlookNameSpace.CreateRecipient("[email protected]")
    Objowner.Resolve
    If objowner.Resolved then
        Set Folder = OutlookNameSpace.GetSharedDefaultFolder(objowner, olFolderInbox) 
    End if

    Dim strDateFilter As String: 
    StrDateFilter = "[ReceivedTime] >= '" & Format(Range("Date").Value, "dddd h:nn AMPM") & "'" 
    Dim Items As Object: Set Items = Folder.Items.Restrict(strDateFilter) 

    i = 1
    For each OutlookMail in Items

        Range("eMail_subject").offset(i,0).Value = OutlookMail.Subject
        Range("eMail_date").offset(i,0).Value = OutlookMail.ReceivedTime
        Range("eMail_Sender").offset(i,0).Value =  OutlookMail.SenderName
        Range("eMail_text").offset(i,0).Value = OutlookMail.Body

        i = i + i


    Set Folder = Nothing
    Set OutlookNameSpace = Nothing
    Set OutlookApp = Nothing

End Sub

I need to extract emails from four more shared mailboxes (other than [email protected]).

1. [email protected]
2. [email protected]
3. [email protected]
4. [email protected]

I tried to insert the following lines.

Dim Folder2 as MAPIfolder
Dim Folder3 as MAPIfolder
Dim Folder4 as MAPIfolder
Dim Folder5 as MAPIfolder
Dim objownwr2 as Variant
Dim objownwr3 as Variant
Dim objownwr4 as Variant
Dim objownwr5 as Variant

Set objowner2 =  OutlookNameSpace.CreateRecipient("[email protected]")
Objowner2.Resolve '(and so on for all the other shared mailbox)

If objowner2.Resolved then
    Set Folder =  OutlookNameSpace.GetSharedDefaultFolder(objowner2, olFolderInbox) 
End if

And so on. It only gets the emails from [email protected].

Answer 1

Now with only one outlook.application:

sub start()
        Dim OutlookApp As Outlook.Application: Set OutlookApp = New Outlook.Application
        Dim OutlookNameSpace As Namespace: Set OutlookNameSpace = OutlookApp.GetNamespace("MAPI")
        
       call GetFromOutlook("[email protected]", OutlookNameSpace)
       call GetFromOutlook("[email protected]", OutlookNameSpace)
       call GetFromOutlook("[email protected]", OutlookNameSpace )
       call GetFromOutlook("[email protected]", OutlookNameSpace )
       call GetFromOutlook("[email protected]", OutlookNameSpace )

       Set OutlookNameSpace = Nothing
       Set OutlookApp = Nothing
End sub

Sub GetFromOutlook(mailadress As String, OutlookNameSpace As Namespace)
        Dim Folder as MAPIfolder
        Dim OutlookMail As Variant
        Dim objowner As Variant
        Dim i as Integer
    
        Set objowner = OutlookNameSpace.CreateRecipient(mailadress)
        Objowner.Resolve
        If objowner.Resolved then
        Set Folder = OutlookNameSpace.GetSharedDefaultFolder(objowner, olFolderInbox) 
        End if
    
        Dim strDateFilter As String: 
        StrDateFilter = "[ReceivedTime] >= '" & Format(Range("Date").Value, "dd.MM.yyyy h:nn AMPM") & "'" 
        Dim Items As Object: Set Items = Folder.Items.Restrict(strDateFilter) 
    
        i = 1
        For each OutlookMail in Items
    
        Range("eMail_subject").offset(i,0).Value = OutlookMail.Subject
        Range("eMail_date").offset(i,0).Value = OutlookMail.ReceivedTime
        Range("eMail_Sender").offset(i,0).Value =  OutlookMail.SenderName
        Range("eMail_text").offset(i,0).Value = OutlookMail.Body
    
        i = i + 1
        Next

        Set Folder = Nothing
        Set OutlookNameSpace = Nothing
        Set OutlookApp = Nothing
    
        End Sub