Запуск VBA в общем почтовом ящике Outlook 365

У меня есть этот код для сохранения вложений из электронных писем с определенным отправителем и темой, вплоть до моего жесткого диска. Он отлично работает, когда он работает только в моем личном почтовом ящике. Но мне нужно, чтобы он работал с общим почтовым ящиком, который есть у моих коллег.

У меня есть этот код в «ThisOutlookSession»:

Private WithEvents olInboxItems As Items  Private Sub Application_Startup() Dim objNS As NameSpace Set objNS = Application.Session  Set olInboxItems = GetFolderPath("name of the shared mailbox\Inbox").Items Set objNS = Nothing End Sub   Private Sub Items_ItemAdd(ByVal item As Object)  On Error GoTo ErrorHandler  'Only act if it's a MailItem Dim Msg As Outlook.MailItem If TypeName(item) = "MailItem" Then Set Msg = item  'Change variables to match need. Comment or delete any part unnecessary. If (Msg.SenderName = "Sender name") And _ (Msg.Subject = "test") And _ (Msg.Attachments.Count >= 1) Then  'Set folder to save in. Dim olDestFldr As Outlook.MAPIFolder Dim myAttachments As Outlook.Attachments Dim Att As String  'location to save in. Can be root drive or mapped network drive. Const attPath As String = "U:\TESTING\"  ' save attachment Set myAttachments = item.Attachments Att = myAttachments.item(1).DisplayName myAttachments.item(1).SaveAsFile attPath & Att  ' mark as read Msg.UnRead = False End If  End If  ProgramExit: Exit Sub ErrorHandler: MsgBox Err.Number & " - " & Err.Description Resume ProgramExit End Sub 

Тогда у меня есть эта функция GetFolderPath в моем модуле:

' Use the GetFolderPath function to find a folder in non-default mailboxes Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder Dim oFolder As Outlook.Folder Dim FoldersArray As Variant Dim i As Integer  On Error GoTo GetFolderPath_Error If Left(FolderPath, 2) = "\\" Then FolderPath = Right(FolderPath, Len(FolderPath) - 2) End If 'Convert folderpath to array FoldersArray = Split(FolderPath, "\") Set oFolder = Application.Session.Folders.item(FoldersArray(0)) If Not oFolder Is Nothing Then For i = 1 To UBound(FoldersArray, 1) Dim SubFolders As Outlook.Folders Set SubFolders = oFolder.Folders Set oFolder = SubFolders.item(FoldersArray(i)) If oFolder Is Nothing Then Set GetFolderPath = Nothing End If Next End If 'Return the oFolder Set GetFolderPath = oFolder Exit Function  GetFolderPath_Error: Set GetFolderPath = Nothing Exit Function End Function 

У вас есть предложения, почему это не сработает? большое спасибо