none
Macro para receber automaticamente arquivos dos anexos em eml no outlook 2007 / 2010 RRS feed

  • Pergunta

  • Boa tarde pessoal, conforme consulta no forum, consegui obter a macro abaixo para baixar automaticamente os anexos do meu email para uma pasta no computador, o problema é que tentei cadastrar o arquivo eml nesta regra e ele não funciona, tenho fornecedores que mandam varios emails dentro de apenas um para mim em arquivo eml e esta regra não consegue extrair estes anexos, nem no formato do arquivo direto nem em eml, gostaria de saber se existe alguma outra regra que eu possa resolver este problema, se não esta regra que peguei não vai me ajudar.

    Public Sub ProcessarAnexo(Email As MailItem)
    
        Dim DiretorioAnexos As String
    
        DiretorioAnexos = "C:\fabio"
    
        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
    
                Anexo.SaveAsFile DiretorioAnexos & "\" & Anexo.FileName
    
                
    
            End If
    
        Next
    
       
    
        Set Mail = Application.Session.GetItemFromID(MailID)
    
           
    
        For Each Anexo In Mail.Attachments
    
            If Right(Anexo.FileName, 3) = "pdf" Then
    
                Anexo.SaveAsFile DiretorioAnexos & "\" & Anexo.FileName
    
       
    
         End If
    
        Next
    
      
    
        Set Mail = Nothing
    
    End Sub


    Sem mais, agradeço, aguardo ansiosamente e fico a disposição.

    Att,

    Fabio de Seixas



    • Editado Fábio JrModerator quinta-feira, 26 de dezembro de 2013 15:38 Formatação do código
    terça-feira, 24 de dezembro de 2013 15:42

Respostas

  • Fábio,

    Quanto ao nome do arquivo, veja que você tem uma váriavel "i" de bobeira no seu código, porque não usá-la para identificar cada arquivo, assim:

    Public Sub ProcessarAnexo(Email As MailItem)
        Dim DiretorioAnexos As String
        Dim strDATAHORA As String
        Dim NomeArquivo As String
        
        DiretorioAnexos = "C:\fabio"
        
        strDATAHORA = Right("0" & Day(Now), 2) & Right("0" & Month(Now), 2) & Year(Now) & _
                    " " & Right("0" & Hour(Now), 2) & Right("0" & Minute(Now), 2) & Right("0" & Second(Now), 2)
    
        Dim MailID As String
        Dim Mail As Outlook.MailItem
    
        MailID = Email.EntryID
        Set Mail = Application.Session.GetItemFromID(MailID)
    
        i = 1
        For Each Anexo In Mail.Attachments
            If Right(Anexo.FileName, 3) = "msg" Then
                NomeArquivo = Left(Anexo.FileName, Len(Anexo.FileName) - 4) & _
    				"_" & strDATAHORA & _
    				i & _
    				Right(Anexo.FileName, 4)
    				
                Anexo.SaveAsFile DiretorioAnexos & "\" & NomeArquivo
                i=i+1
            End If
        Next
    
        Set Mail = Nothing
     End Sub

    Veja que precisei incrementar a contagem após salvar o arquivo.


    Fábio de Paula Junior

    • Sugerido como Resposta Edinaldo Junior sexta-feira, 27 de dezembro de 2013 21:14
    • Marcado como Resposta Fabio de sEIXAS sábado, 28 de dezembro de 2013 02:53
    • Não Marcado como Resposta Fabio de sEIXAS sábado, 28 de dezembro de 2013 02:53
    • Marcado como Resposta Fabio de sEIXAS sábado, 28 de dezembro de 2013 02:54
    sexta-feira, 27 de dezembro de 2013 20:11
    Moderador

Todas as Respostas

  • Fábio,

    O seu código toma ações quanto a arquivos PDF e XML, quando você recebe um desses ele funciona?, isto é, salva o anexo na pasta c:\fabio?


    Fábio de Paula Junior

    quinta-feira, 26 de dezembro de 2013 15:45
    Moderador
  • Falai ai Fábio, blzera?

    Então, quanto recebo um email com arquivos xml ou pdf ele salva os arquivos corretamente, mas se um fornecedor me manda um email com outro email dentro, no formato eml/msg e dentro deste eml tem os arquivos pdf ou xml ele não salva.

    Eu consigui fazer com que ele salve o arquivo msg na minha pasta, ai desta forma eu pego este arquivo e arrasto para minha caixa de entrada e mando rodar novamente a função acima para baixar o pdf e xml, ai dá certo.

    Porem tenho um outro problema, se tenho arquivos com o mesmo nome, ele não consegue salvar os dois arquivos, consegui um outro script conforme abaixo, colocando data, hora e segundo pensando que ia funcionar mais nada, eu precisaria de alguma função que criasse no final do arquivo um codigo sequencial, exemplo "0001", "0002", por assim em diante, para conseguir salvar arquivos que estejam com o mesmo nome e no mesmo email, entendeu?

    Ou se existisse na função time que vá até o milésimo de segundo também funcionaria, mas pelo que vi não existe esta função.

    Public Sub ProcessarAnexo(Email As MailItem)
        Dim DiretorioAnexos As String
        Dim strDATAHORA As String
        Dim NomeArquivo As String
        
        DiretorioAnexos = "C:\fabio"
        
        strDATAHORA = Right("0" & Day(Now), 2) & Right("0" & Month(Now), 2) & Year(Now) & _
                    " " & Right("0" & Hour(Now), 2) & Right("0" & Minute(Now), 2) & Right("0" & Second(Now), 2)
    
        Dim MailID As String
        Dim Mail As Outlook.MailItem
    
        MailID = Email.EntryID
        Set Mail = Application.Session.GetItemFromID(MailID)
    
        i = 1
        For Each Anexo In Mail.Attachments
            If Right(Anexo.FileName, 3) = "msg" Then
                NomeArquivo = Left(Anexo.FileName, Len(Anexo.FileName) - 4) & "_" & strDATAHORA & Right(Anexo.FileName, 4)
                Anexo.SaveAsFile DiretorioAnexos & "\" & NomeArquivo
                
            End If
        Next
    
        Set Mail = Nothing
     End Sub




    Sem mais, agradeço desde já, aguardo ansiosamente e fico a disposição.


    • Editado Fábio JrModerator sexta-feira, 27 de dezembro de 2013 19:51 Formatação do código
    quinta-feira, 26 de dezembro de 2013 20:27
  • Você tem que fazer duas etapas.

    1ª - Salvar os arquivos msg, isso você já consegue.

    2ª - Extrair os arquivos de dentro do msg.

    O código abaixo está em .VBS, não tenho como testar no outlook mas não deve ser dificil, ele lê o conteúdo de uma pasta (onde estão os .MSGs) e retirar os anexos .pdf, ao final ele apaga o arquivo .msg.

    strPastaMSG="C:\fabio"
    DiretorioAnexos="C:\fabio"
    Set ol  = CreateObject("Outlook.Application")
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Set Files = fso.GetFolder(strPastaMSG).files
    
    For Each f In Files
    	If LCase(fso.GetExtensionName(f)) = "msg" Then
    	
    		Set msg = ol.CreateItemFromTemplate(f.Path)
    		WScript.Echo msg.Sender.Name
    		For Each rcpt In msg.Recipients
    		  WScript.Echo rcpt.Name
    		Next
    
    		For Each Anexo In msg.Attachments
    			If Right(Anexo.FileName, 3) = "pdf" Then
    				Anexo.SaveAsFile DiretorioAnexos & "\" & Anexo.FileName
    			End If
    		Next
    
    		fso.DeleteFile(f.Path)
    	End If
    Next

    Ref.:

    Using VB Script to read contents of .msg file

    http://stackoverflow.com/questions/17942824/using-vb-script-to-read-contents-of-msg-file


    Fábio de Paula Junior

    • Sugerido como Resposta Edinaldo Junior sexta-feira, 27 de dezembro de 2013 11:53
    • Não Sugerido como Resposta Edinaldo Junior sexta-feira, 27 de dezembro de 2013 15:00
    quinta-feira, 26 de dezembro de 2013 20:50
    Moderador
  • Fábio, a proposta do Fábio Jr resolveu?

    Edinaldo Oliveira

    Esse conteúdo é fornecido sem garantias de qualquer tipo, seja expressa ou implícita.

    ** Por favor, lembre-se de “Marcar como Resposta” as respostas que resolveram o seu problema. Essa é uma maneira comum de reconhecer aqueles que o ajudaram e fazer com que seja mais fácil para os outros visitantes encontrarem a resolução mais tarde. **

    sexta-feira, 27 de dezembro de 2013 11:53
  • Boa tarde Fabio / Edinaldo, então, agradeço pela atenção, porem o meu problema é que estou com um email onde tem dois arquivos com o mesmo nome, e o script só consegue salvar um, pela função strDATAHORA eu precisaria que ele alcançasse até o milésimo ou se não criar alguma regra que ele crie valores sequenciais para os arquivo, tipo "0001", "0002", assim por diante.

    Sem mais, agradeço, aguardo ansiosamente e fico a disposição.

    Att,

    Fabio de Seixas.

    sexta-feira, 27 de dezembro de 2013 14:57
  • Fábio,

    Quanto ao nome do arquivo, veja que você tem uma váriavel "i" de bobeira no seu código, porque não usá-la para identificar cada arquivo, assim:

    Public Sub ProcessarAnexo(Email As MailItem)
        Dim DiretorioAnexos As String
        Dim strDATAHORA As String
        Dim NomeArquivo As String
        
        DiretorioAnexos = "C:\fabio"
        
        strDATAHORA = Right("0" & Day(Now), 2) & Right("0" & Month(Now), 2) & Year(Now) & _
                    " " & Right("0" & Hour(Now), 2) & Right("0" & Minute(Now), 2) & Right("0" & Second(Now), 2)
    
        Dim MailID As String
        Dim Mail As Outlook.MailItem
    
        MailID = Email.EntryID
        Set Mail = Application.Session.GetItemFromID(MailID)
    
        i = 1
        For Each Anexo In Mail.Attachments
            If Right(Anexo.FileName, 3) = "msg" Then
                NomeArquivo = Left(Anexo.FileName, Len(Anexo.FileName) - 4) & _
    				"_" & strDATAHORA & _
    				i & _
    				Right(Anexo.FileName, 4)
    				
                Anexo.SaveAsFile DiretorioAnexos & "\" & NomeArquivo
                i=i+1
            End If
        Next
    
        Set Mail = Nothing
     End Sub

    Veja que precisei incrementar a contagem após salvar o arquivo.


    Fábio de Paula Junior

    • Sugerido como Resposta Edinaldo Junior sexta-feira, 27 de dezembro de 2013 21:14
    • Marcado como Resposta Fabio de sEIXAS sábado, 28 de dezembro de 2013 02:53
    • Não Marcado como Resposta Fabio de sEIXAS sábado, 28 de dezembro de 2013 02:53
    • Marcado como Resposta Fabio de sEIXAS sábado, 28 de dezembro de 2013 02:54
    sexta-feira, 27 de dezembro de 2013 20:11
    Moderador
  • Boa noite Fabio, muito obrigado mesmo, não sei nem como te agradecer pela ajuda, era o que eu precisava, parabéns pelo conhecimento compartilhado.

    Só fiquei com duvida sobre a função i = i, mas tudo blz, vlw mesmo, muito obrigado.

    sábado, 28 de dezembro de 2013 02:54