Read Emails from a shared account in Outlook

I have VBA code that reads the emails in a folder directly under the Inbox.

It works when the mailbox is my personal account on the server at work. I also have permissions to a shared mailbox on the server at work. I can send mail out on behalf of this shared account. However when I try to use the same code with this mailbox to read it, it cannot find an object; namely, it won't let me get to the mailbox for the purposes of reading the folders. The line the code fails on is highlighted.

Here is the code. The only difference between the version that works and the version that doesn't work is the mailbox name that I pass to the subroutine. My IT department blames it on the VB code. This same code also works with my 365 HOME Outlook and has worked with a former employer on a shared account on an exchange server.

What should I tell my IT department to do to make this work for me?

Option Explicit

Sub ReadMail(MailBox As String, SubFolder As String, sht As Worksheet)

' Mailbox = mailbox name

' Subfolder = folder directly under Inbox

' sht = the sheet with the output table

Dim olApp As Object ' Outlook Application

Dim olNS As Object ' Outlook Name Space

Dim FldrIn As Object ' Dock Schedule folder

Dim FldrOut As Object ' Dock Schedule processed folder

Dim olAtt As Object ' Outlook attachement

Dim k As Long ' Index to folder item

Dim FileName As String ' File names in folder

Dim RowNum As Long ' Row Number for Output Table

Const olMailItem As Long = 0

' Initalize variables

RowNum = 2

' Set up mailbox

Set olApp = CreateObject("Outlook.Application")

Set olNS = olApp.GetNamespace("MAPI")

Set FldrIn = olNS.Folders(MailBox).Folders("Inbox").Folders(SubFolder)

DoEvents

Set FldrOut = olNS.Folders(MailBox).Folders("Inbox").Folders(SubFolder)

Application.ScreenUpdating = False

Application.DisplayAlerts = False

' Go through mail items bottom to top

For k = FldrIn.items.Count To 1 Step -1

On Error Resume Next 

sht.Cells(RowNum, "A") = FldrIn.items(k).Sender 

sht.Cells(RowNum, "B") = FldrIn.items(k).Subject 

sht.Cells(RowNum, "C") = FldrIn.items(k).ReceivedTime 

sht.Cells(RowNum, "D") = FldrIn.items(k).Body 

On Error GoTo 0 

RowNum = RowNum + 1 

Next k

' Clean up Outlook

Set FldrIn = Nothing

Set olNS = Nothing

Set olApp = Nothing

Application.DisplayAlerts = True

Application.ScreenUpdating = True

Application.StatusBar = False

End Sub