none
Macro para ler o conteudo de um email recebido no Outlook e salvar seus anexos em uma pasta de Documentos. RRS feed

  • Pergunta

  • Bom dia Pessoal,

    Tenho um sistema de chamados(Helpdesk) aqui na minha empresa. Gostaria de criar um aplicativo ou macro, que pegue os e-mails recebidos no Outlook e automaticamente salve seus anexos em uma pasta do computador.


    Será que isso é viável?

    Obrigada.

    terça-feira, 18 de abril de 2017 15:44

Todas as Respostas

  • Você pode usar o código abaixo e alterar de acordo com a sua necessidade. Se precisar de ajuda dá um grito! :)

    A macro percorre todos os e-mails que estão dentro de uma pasta do Outlook. E salva todos os anexos que contem em cada e-mail em uma pasta especificada por você.

    Sub Save_Mail_Attachment()
    
    
        Dim ns As Namespace
        Dim inb As Folder
        Dim itm As MailItem
        Dim atch As Attachment
        Dim olNS As Object
        Dim olFolder As Object
        Dim appOutlook As Object
    
        'Definindo o Aplicativo do outlook a Variavel appOutlook
        Set appOutlook = CreateObject("Outlook.Application")
    
        
        Set ns = Outlook.GetNamespace("MAPI")
        Set inb = ns.Folders("PietroFarias").Folders("Caixa de Entrada").Folders("Teste")
     
    
        'NOME DA PASTA ONDE SERÁ SALVO OS ANEXOS
        File_Path = "C:\PastaTeste\"
     
    
        '''''Loop em cada e-mail da pasta
        For Each itm In inb.Items
    
    
        '''''Loop em cada anexo do e-mail (inclui imagem que pode haver nas assinaturas)
            For Each atch In itm.Attachments
                On Error Resume Next
    'Aqui é salvo o anexo dentro da pasta informada
                atch.SaveAsFile File_Path & atch.Filename
            Next atch
    
        Next itm
    
        '''''Notificação da finalização da Macro
        MsgBox "Solicitações salvas em: " & File_Path
    
    
        'Abre a pasta onde os anexos foram salvos
        Shell "C:\WINDOWS\explorer.exe """ & File_Path & "", vbNormalFocus
        
    
    
    End Sub



    quinta-feira, 20 de abril de 2017 11:21