Outlook 2016 outlook vba to look into shared mailbox

[MarkBickers_1]

Hi There,

I am using the below code to look into Shared mailbox emails and copy data from email body to excel . The code works fine if I am using personal mailbox but it gives Runtime error "The attempted operation failed. An object could not be found" if I use the shared mailbox in the highlighted line. Can anyone please let me know what changes need to be made to make it work for shared mailbox .

Public Sub Extract()
    
    On Error Resume Next
    
    Set myOlApp = Outlook.Application
    Set mynamespace = myOlApp.GetNamespace("mapi")
  
    Dim strRowData As String
    Dim strDelimiter As String
    Dim myDestFolder As Outlook.Folder
    Dim olRecip As Outlook.Recipient
    Dim ShareInbox As Outlook.MAPIFolder
    Dim SubFolder As Object
    Dim j As Integer
    Dim m As String
    Dim InputF As String
    Dim OutputP As String
    Dim ProdMail As String
    
    Dim oXLApp As Object, oXLwb As Object, oXLws As Object
    
    Dim lRow As Long
    
    On Error Resume Next
    Set oXLApp = GetObject(, "Excel.Application")
    
    '~~> If not found then create new instance
    If Err.Number <> 0 Then
        Set oXLApp = CreateObject("Excel.Application")
    End If
    Err.Clear
    On Error GoTo 0
    
    '~~> Open the relevant file
    Set oXLwb = oXLApp.Workbooks.Open("C:\ETest.xlsx")
           
    'Extract Mailbox and subfolder details from a sheet named as "Folder Details"
    
    Set oXLws = oXLwb.Sheets("Folder Details")
           
    ProdMail = oXLws.Range("B1")
    InputFolder = oXLws.Range("B2")
    OutputFolder = oXLws.Range("B3")
       
       
    strRowData = ""
    
    ' Code to extract emails from specific subfolder within shared folder and copy the data across excel spreadsheet.
    
    Set olRecip = mynamespace.CreateRecipient(ProdMail)
       
    Set ShareInbox = mynamespace.GetSharedDefaultFolder(olRecip, olFolderInbox) ' Look into Inbox emails
    Set SubFolder = ShareInbox.Folders(InputFolder) 'Change this line to specify folder
    Set myDestFolder = ShareInbox.Folders(OutputFolder)
      
      If ShareInbox.Folders(InputFolder) = 0 Then
       MsgBox "New Apps folder doesn't exist"
       Exit Sub
    End If
    
    If ShareInbox.Folders(OutputFolder) = 0 Then
       MsgBox "Completed Apps folder doesn't exist"
       Exit Sub
    End If
    
      
    Set oXLws = oXLwb.Sheets("Output")
    
    oXLwb.worksheets("Output").Cells.Clear
          
    lRow = 2
     
    oXLws.Range("A1").Value = "Name"
    oXLws.Range("B1").Value = "ID"
    oXLws.Range("C1").Value = "Address"
    oXLws.Range("D1").Value = "Phone Number"
   
    
   If SubFolder.Items.Count = 0 Then
   
      MsgBox "There are no emails in the " & InputFolder & " folder", , "No Emails"
      
      Exit Sub
    
   End If
    
    For I = 1 To SubFolder.Items.Count
    
        messageArray = ""
        strRowData = ""
    
        Set myitem = SubFolder.Items(1)
        
        msgtext = Trim(myitem.Body)
        
       'search for specific text
    
        delimtedMessage = Replace(Trim(msgtext), "A1", "###")
               
        delimtedMessage = Replace(Trim(delimtedMessage), "B1", "###")
                
        delimtedMessage = Replace(Trim(delimtedMessage), "C1", "###")
                
        delimtedMessage = Replace(delimtedMessage, "D1", "###")
                
        messageArray = Split(delimtedMessage, "###")
        
          With oXLws
           
                .Range("A" & lRow).Value = messageArray(1)
                .Range("B" & lRow).Value = messageArray(2)
                .Range("C" & lRow).Value = messageArray(3)
                .Range("D" & lRow).Value = messageArray(4)
                             
           End With
            
            lRow = lRow + 1
                       
        myitem.Move myDestFolder
  
    Next I
        
        oXLwb.Save
    
        oXLwb.Close (True)
        
        MsgBox "The Macro ran successfully."
                  
    End Sub