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

  • Pergunta

  • 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,

    quinta-feira, 16 de abril de 2015 18:17

Todas as Respostas

  • 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.

    quinta-feira, 16 de abril de 2015 20:01
  • 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

    sexta-feira, 17 de abril de 2015 17:11