Executando o VBA em uma caixa de correio compartilhada Outlook 365

Question

Eu tenho este código para salvar anexos de e-mails com um remetente e tópico específicos, até o meu disco rígido. Funciona bem quando está trabalhando apenas na minha caixa de correio pessoal. Mas preciso que funcione com a caixa de correio compartilhada que tenho com meus colegas de trabalho.

Eu tenho este código no "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

Então eu tenho essa função GetFolderPath no meu módulo:

' 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

Você tem alguma sugestão de por que não funciona? Muito obrigado

    

Answer 1

A razão pela qual não está funcionando, é porque você precisa adicionar a caixa de correio compartilhada como uma segunda conta. Só então o VBA conseguirá encontrar a caixa de correio e trabalhar com ela.

Você pode simplesmente adicionar a caixa de correio fornecendo o endereço de e-mail e uma senha falsa. Quando o prompt de login chegar, digite seu próprio endereço de e-mail / nome de usuário e senha e ele será adicionado como um segundo endereço de e-mail.

Note que você tem que fechar o Outlook e reabri-lo (talvez duas vezes) antes que ele mescle ambas as contas como uma única conta. Caso contrário, você verá duas vezes.