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

Question

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

У меня есть этот код в "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

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

Answer 1

Причина, по которой он не работает, заключается в том, что вам нужно добавить общий почтовый ящик в качестве второй учетной записи. Только тогда VBA сможет найти почтовый ящик и работать с ним.

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

Обратите внимание, что вы должны закрыть Outlook и снова открыть его (возможно, дважды), прежде чем он объединит обе учетные записи в одну. В противном случае вы увидите это дважды.