Criar Macro que salva todos os E-mail recebidos com anexo XML Outlook 2013

Question

Olá,

Estou precisando muito fazer uma macro onde todos os e-mail que eu receber, ele salve automaticamente em uma pasta criada no meu C:\

 vi outros forum  e estou usando o seguinte VBA:

                

Public Sub ProcessarAnexo(Email As MailItem)
    Dim DiretorioAnexos As String
    DiretorioAnexos = "C:\NFE"

    Dim MailID As String
    Dim Mail As Outlook.MailItem

    MailID = Email.EntryID
    Set Mail = Application.Session.GetItemFromID(MailID)

    For Each anexo In Mail.Attachments
        If Right(anexo.FileName, 3) = "xml" Then
            MsgBox (anexo.FileName)
            anexo.SaveAsFile DiretorioAnexos & anexo.FileName
        End If
    Next

    Set Mail = Nothing
End Sub

Porém quando eu coloco em pratica no outlook ele mostra o seguinte erro '-2147023582(80070522)'

Agradeço a ajuda,

Answer 1

Boa Tarde Jonatas,

O Erro (80070522) normalmente é associado à permissões, verifique se tem permissão ao diretório C:\, à pasta em questão.

Acesse esse link e veja se resolve sua dúvida.

Espero ter ajudado

Abraço.

Answer 2

Olá Jonatas, 

Fiz o mesmo código aqui e consegui mover para a área de trabalho, no C:\ precisa de permissão mesmo, segue o código.

Public Sub ProcessarAnexo()

Dim InboxMsg As Object

Dim DeletedItems As Outlook.Folder
Dim MsgAttachment As Outlook.Attachment
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.Folder

    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.Session.GetDefaultFolder(olFolderInbox)

    Dim DiretorioAnexos As String
    
    'COLOCAR O ENDEREÇO DA SUA ÁREA DE TRABALHO PARA VALIDAR SE É PERMISSÃO MESMO
    DiretorioAnexos = "CaminhoDoArquivoComPermissão"
    Dim MailID As String
    Dim Mail As Outlook.MailItem
    
    'Varre Caixa de Entrada
    
    For Each InboxMsg In Inbox.Items
        If InboxMsg.Class = olMail Then
    
    'Varre em busca de anexo
    
   For Each MsgAttachment In InboxMsg.Attachments
                If Right(MsgAttachment.DisplayName, 3) = "txt" Then
            
            'Move arquivo para uma pasta com permissão
            MsgAttachment.SaveAsFile DiretorioAnexos & MsgAttachment.FileName
        End If
    Next
End If
Next
    Set Mail = Nothing
End Sub