none
Importar dados do Outlook para txt,xls etc RRS feed

  • Pergunta

  • Bom dia.

    Preciso de uma ajuda. Mensalmente tenho que extrair todos os e-mails respondidos .

    Gostaria de saber se é possivel atraves de uma macro extrair para um txt, excel... as seguintes informações :

    Mensagem / Destinatario / Titulo email / Data recebimento / Data envio/ Primeiros 30 caracteres do e-mail.

    E caso possua alguma excessão que não seja necessario seja possivel incluir nesse filtro.

    Muito obrigado.

    Thiago

    terça-feira, 3 de setembro de 2013 12:53

Respostas

  • Sub fncRelatório()
        'Execute esta macro no Outlook
        
        'Altere o caminho abaixo
        Const cstrOutput As String = "c:\temp\Relatório.txt"
    
        Dim intFF As Integer
        Dim lngMonth As Long
        Dim lngYear As Long
        Dim mli As MailItem
        Dim rcp As Recipient
        Dim ctt As ContactItem
        Dim nms As NameSpace
        Dim objAllItems As Outlook.Items
        Dim objFilteredItems As Outlook.Items
        Dim objItem As Object
        Dim strCriteria As String
        Dim strDepartament As String
        Dim strOfficeLocation As String
     
        lngYear = InputBox("Digite o ano de pesquisa:", , Year(Date))
        lngMonth = InputBox("Digite o mês de pesquisa:", , Month(Date))
     
        If lngYear < 1900 Or lngYear > 3000 Or lngMonth < 1 Or lngMonth > 12 Then
            MsgBox "Dados de entrada incorretos.", vbCritical
            Exit Sub
        End If
     
        Set nms = Application.GetNamespace("MAPI")
        'Altere as pastas abaixo para como está configurado seu e-mail:
        Set objAllItems = nms.Folders("seu@emailcom").Folders("Itens Enviados").Items
        
        strCriteria = "[ReceivedTime] > " & "'" & DateSerial(lngYear, lngMonth, 1) & "'" _
        & " And [ReceivedTime] < " & "'" & DateSerial(lngYear, lngMonth + 1, 1) & "'"
        Set objFilteredItems = objAllItems.Restrict(strCriteria)
    
        intFF = FreeFile
        Open "c:\temp\Relatório.txt" For Output As #intFF
        For Each objItem In objFilteredItems
            If TypeName(objItem) = "MailItem" Then
                Set rcp = Nothing
                Set ctt = Nothing
                strDepartament = ""
                strOfficeLocation = ""
                Set rcp = mli.Recipients(1).Resolve
                If rcp.Resolved Then
                    Set ctt = rcp.AddressEntry.GetContact
                    If Not ctt Is Nothing Then
                        strDepartament = ctt.Department
                        strOfficeLocation = ctt.OfficeLocation
                    End If
                End If
                Print #intFF, "Título: " & mli.Subject
                Print #intFF, "Destinatário: " & mli.To
                Print #intFF, "Departamento: " & strDepartament
                Print #intFF, "Local do Escritório: " & strOfficeLocation
                Print #intFF, "Data Envio: " & mli.SentOn
                Print #intFF, "Corpo da Mensagem: " & Left(mli.Body, 50)
                Print #intFF, ""
            End If
        Next objItem
        Close #intFF
    End Sub


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br


    quinta-feira, 12 de setembro de 2013 23:35
    Moderador

Todas as Respostas

  • Utilize o código abaixo.

    Sub fncRelatório()
        'Execute esta macro no Outlook
        
        'Altere o caminho abaixo
        Const cstrOutput As String = "c:\temp\Relatório.txt"
    
        Dim intFF As Integer
        Dim lngMonth As Long
        Dim lngYear As Long
        Dim mli As MailItem
        Dim nms As NameSpace
        Dim objAllItems As Outlook.Items
        Dim objFilteredItems As Outlook.Items
        Dim objItem As Object
        Dim strCriteria As String
     
        lngYear = InputBox("Digite o ano de pesquisa:", , Year(Date))
        lngMonth = InputBox("Digite o mês de pesquisa:", , Month(Date))
     
        If lngYear < 1900 Or lngYear > 3000 Or lngMonth < 1 Or lngMonth > 12 Then
            MsgBox "Dados de entrada incorretos.", vbCritical
            Exit Sub
        End If
     
        Set nms = Application.GetNamespace("MAPI")
        'Altere as pastas abaixo para como está configurado seu e-mail:
        Set objAllItems = nms.Folders("seu@email.com").Folders("Itens Enviados").Items
        
        strCriteria = "[ReceivedTime] > " & "'" & DateSerial(lngYear, lngMonth, 1) & "'" _
        & " And [ReceivedTime] < " & "'" & DateSerial(lngYear, lngMonth + 1, 1) & "'"
        Set objFilteredItems = objAllItems.Restrict(strCriteria)
    
        intFF = FreeFile
        Open "c:\temp\Relatório.txt" For Output As #intFF
        For Each objItem In objFilteredItems
            If TypeName(objItem) = "MailItem" Then
                Set mli = objItem
                Print #intFF, "Título: " & mli.Subject
                Print #intFF, "Destinatário: " & mli.SenderEmailAddress
                Print #intFF, "Data Envio: " & mli.SentOn
                Print #intFF, "Corpo da Mensagem: " & Left(mli.Body, 30)
                Print #intFF, ""
            End If
        Next objItem
        Close #intFF
    End Sub

    ---

    Qual a diferença entre Mensagem e Título do e-mail?

    ---

    Vi que você deseja saber a data de recebimento. No caso, seria do e-mail que originou a sua resposta? Se sim, pesquisa as propriedades ConversationIndex, ConversationID e ConversationTopic do objeto MailItem. Ela fornece meios de você descobrir o e-mail pai da resposta.



    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    quarta-feira, 4 de setembro de 2013 00:49
    Moderador
  • Muito obrigado pela resposta.

    Fiquei muito feliz em ver que existe algo proximo do que eu sonhava rs.

    Vou tentar explicar melhor: mensalmente possuimos uma planilha de atendimento interno que temos que preencher.

    nessa planilha possuimos os seguintes campos :

    E-mail(remetente) / data recebimentoDepartamento / Ação tomada / data de resposta / data de solução

    Porem existem algumas excessoes que não incluimos nessa planilha (a excessão poderia ser tratada atraves do Alias do usuario).

    Observei que a macro trouxe as seguintes informações :

    Título: RES: NF 41089
    Destinatário: /O=ETN/OU=CLETCC/cn=Recipients/cn=C9978973  ; precisaria que fosse o e-mail
    Data Envio: 05/08/2013 09:03:51
    Corpo da Mensagem: Bom dia.

    Notei que o corpo da mensagem em praticamente todo import veio com somente o "Bom dia".

    Muito obrigado pela ajuda.

    quarta-feira, 4 de setembro de 2013 11:37
  • Troque

    Print #intFF, "Destinatário: " & mli.SenderEmailAddress

    por

    Print #intFF, "Destinatário: " & mli.To

    ---

    Sobre o corpo da mensagem, experimente aumentar o valor 30 da função Left mostrada abaixo:

    Print #intFF, "Corpo da Mensagem: " & Left(mli.Body, 30)

    30 representa o número de caracteres que você está extraindo do corpo da mensagem.


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    quinta-feira, 5 de setembro de 2013 01:01
    Moderador
  • Muitissimo obrigado meu amigo.

    foi de grande ajuda.

    Uma ultima duvida , para eu incluir o Departamento do contato e do Escritório , poderia somente me informar quais os códigos dos campos ?

    Obrigado novamente.

    quinta-feira, 5 de setembro de 2013 11:43
  • Sub fncRelatório()
        'Execute esta macro no Outlook
        
        'Altere o caminho abaixo
        Const cstrOutput As String = "c:\temp\Relatório.txt"
    
        Dim intFF As Integer
        Dim lngMonth As Long
        Dim lngYear As Long
        Dim mli As MailItem
        Dim rcp As Recipient
        Dim ctt As ContactItem
        Dim nms As NameSpace
        Dim objAllItems As Outlook.Items
        Dim objFilteredItems As Outlook.Items
        Dim objItem As Object
        Dim strCriteria As String
        Dim strDepartament As String
        Dim strOfficeLocation As String
     
        lngYear = InputBox("Digite o ano de pesquisa:", , Year(Date))
        lngMonth = InputBox("Digite o mês de pesquisa:", , Month(Date))
     
        If lngYear < 1900 Or lngYear > 3000 Or lngMonth < 1 Or lngMonth > 12 Then
            MsgBox "Dados de entrada incorretos.", vbCritical
            Exit Sub
        End If
     
        Set nms = Application.GetNamespace("MAPI")
        'Altere as pastas abaixo para como está configurado seu e-mail:
        Set objAllItems = nms.Folders("seu@emailcom").Folders("Itens Enviados").Items
        
        strCriteria = "[ReceivedTime] > " & "'" & DateSerial(lngYear, lngMonth, 1) & "'" _
        & " And [ReceivedTime] < " & "'" & DateSerial(lngYear, lngMonth + 1, 1) & "'"
        Set objFilteredItems = objAllItems.Restrict(strCriteria)
    
        intFF = FreeFile
        Open "c:\temp\Relatório.txt" For Output As #intFF
        For Each objItem In objFilteredItems
            If TypeName(objItem) = "MailItem" Then
                Set rcp = Nothing
                Set ctt = Nothing
                strDepartament = ""
                strOfficeLocation = ""
                Set rcp = mli.Recipients(1).Resolve
                If rcp.Resolved Then
                    Set ctt = rcp.AddressEntry.GetContact
                    If Not ctt Is Nothing Then
                        strDepartament = ctt.Department
                        strOfficeLocation = ctt.OfficeLocation
                    End If
                End If
                Print #intFF, "Título: " & mli.Subject
                Print #intFF, "Destinatário: " & mli.To
                Print #intFF, "Departamento: " & strDepartament
                Print #intFF, "Local do Escritório: " & strOfficeLocation
                Print #intFF, "Data Envio: " & mli.SentOn
                Print #intFF, "Corpo da Mensagem: " & Left(mli.Body, 50)
                Print #intFF, ""
            End If
        Next objItem
        Close #intFF
    End Sub


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br


    quinta-feira, 12 de setembro de 2013 23:35
    Moderador
  • Bom dia e obrigado amigo.

    quando executo o depurador critica na seguinte linha :

    Set rcp = mli.Recipient(1).Resolve

    Sabe o que poderia ser ?


    • Editado Tvidal terça-feira, 24 de setembro de 2013 18:35
    segunda-feira, 23 de setembro de 2013 13:00
  • Olá,

    O método resolve é uma ação que o Outlook executa para descobrir se o destinatário está em sua agenda.

    Qual erro você obtém?


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    quarta-feira, 2 de outubro de 2013 00:30
    Moderador
  • A variavel do objeto ou a variavel do bloco  'With' não foi definida.

    na linha : Set rcp = mli.Recipients(1).Resolve

    Verifiquei que voce colocou como caminho a pasta Iens Enviados.

    Porem no caso, essa macro seria como se fosse para uma planilha de atendimento.

    Não sei se pode estar "enroscando" nesse ponto. As informações que necessito(prioridade) acredito terem que vir da caixa de entrada : Data de resposta (quando vc responde um email e na caixa de entrada, quando clica no email  aparece a mensagem de : Voce respondeu essa mensagem em dd/mm/aaaa hh:mm))

    Se rodar hoje no formato que esta + essa data, ficara perfeito.

    Efetuei também uma pequena mudança no print :

    Dim xlsCriterio As String

    xlsCriterio = "Local do Escritório: " & strOfficeLocation & "|" & "Emitente: " & mli.SenderName & "|" & "Data Recebimento: " & mli.ReceivedTime & "|" & "Data Resposta: " & mli.LastModificationTime & "|" & "Título: " & mli.Subject & "|"
               


    quarta-feira, 2 de outubro de 2013 12:24
  • Em relação à data, você pode formatá-la como, por exemplo:

    Format(mli.ReceivedTime, "dd/MM/yyyy hh:mm")

    Sobre o erro Resolve, estou tentando ver se obtenho erro para sugerir uma solução.


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    sexta-feira, 4 de outubro de 2013 03:43
    Moderador
  • Pensando na caixa de entrada....

    a data em que eu recebi o e-mail é o ReceivedTime, a data em que respondi (na propria caixa de entrada) é o LastModificationTime ?

    Pois eu preciso medir baseado nos emails que estão na caixa de entrada o tempo que demorou para ser respondido.

    Lembrando que utilizo o outlook 2010.

    Obrigado novamente.

    sexta-feira, 4 de outubro de 2013 17:15
  • Não, LastModificationTime é uma propriedade que é alterada quando você edita um e-mail pelo Outlook. Você pode abrir um e-mail do Outlook e editar seu conteúdo.

    Para medir o tempo que o e-mail foi respondido, é um pouco mais complicado. Como eu disse, pesquise as propriedades ConversationIndex, ConversationID e ConversationTopic do objeto MailItem. Ela fornece meios de você descobrir o e-mail pai da resposta e então, você descobrirá a propriedade SentOn do e-mail pai.


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    segunda-feira, 7 de outubro de 2013 03:07
    Moderador
  • Amigo,

    verifiquei onde pude e realmente nao consegui nenhum local que mostrasse algo proximo de como relacionar o conversationID da caixa de entrada / Saida.

    Existe um modo de quando for extrair as informações para o excel, colocar a pasta de onde foi retirado (caixa de entrada ou saida)

    Segue Código.

    Sub fncRelatório()
       
        
        Const cstrOutput As String = "\Desktop\Teste Outlook\Relatorio2.xls"
        Dim FF As Integer
        Dim lngMonth As Long
        Dim lngYear As Long
        Dim Folders As Outlook.Folders
        Dim mli As MailItem
        Dim nms As NameSpace
        Dim objAllItems As Outlook.Items
        Dim objAllItems2 As Outlook.Items
        Dim objFilteredItems As Outlook.Items
        Dim objItem As Object
        Dim strCriteria As String
        Dim xlsCriterio As String
        
        lngYear = InputBox("Digite o ano de pesquisa:", , Year(Date))
        lngMonth = InputBox("Digite o mês de pesquisa:", , Month(Date))
        
        
        If lngYear < 1900 Or lngYear > 3000 Or lngMonth < 1 Or lngMonth > 12 Then
            MsgBox "Dados de entrada incorretos.", vbCritical
            Exit Sub
        End If
        Set nms = Application.GetNamespace("MAPI")
        'Altere as pastas abaixo para como está configurado seu e-mail:
        Set objAllItems = nms.Folders("email@email.com").Folders("Caixa de Entrada").Items
        Set objAllItems2 = nms.Folders("email@email.com").Folders("Mensagens Enviadas").Items
        
        strCriteria = "[ReceivedTime] > " & "'" & DateSerial(lngYear, lngMonth, 1) & "'" _
        & " And [ReceivedTime] < " & "'" & DateSerial(lngYear, lngMonth + 1, 1) & "'"
        Set objFilteredItems = objAllItems.Restrict(strCriteria)
        
        FF = FreeFile
        Open "C:\Users\e8760255\Desktop\Relatorio2.xls" For Output As #FF
        For Each objItem In objFilteredItems
            If TypeName(objItem) = "MailItem" Then
                Set mli = objItem
                
                'Print #FF, "Teste:" & mli.LastModificationTime
                
                
                xlsCriterio = "Emitente: " & mli.To & "|" & "Data Recebimento: " & mli.ReceivedTime & "|" & "Data Resposta: " & mli.SentOn & "|" & "Título: " & mli.Subject & "|" _
                & "ConversationID: " & mli.ConversationID & "|" & "ConversationIndex: " & mli.ConversationIndex
                'Print #FF, "Corpo da Mensagem: " & Left(mli.Body, 80)
          
          
          Print #FF, xlsCriterio
          
            End If
        Next objItem
        Close #FF
    End Sub

    Obrigado.
    sexta-feira, 11 de outubro de 2013 19:28
  • Vale a pena estudar um pouco o modelo de objeto de conversações no Outlook: http://code.msdn.microsoft.com/office/Outlook-2010-Manipulate-64fead5e

    Em relação a descobrir a pasta de onde o item foi extraído, você pode utilizar a propriedade mli.Parent.Name, em que mli representa um objeto MailItem.


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    domingo, 13 de outubro de 2013 18:11
    Moderador
  • Amigo,

    sabe me dizer como faco para que  seja extraido as informações da caixa de entrada e saida para o mesmo arquivo excel, porem em abas destintas ?

    Sub fncRelatório()
       
        
        Const cstrOutput As String = "\Desktop\Teste Outlook\Relatorio2.xls"
        Dim FF As Integer
        Dim lngMonth As Long
        Dim lngYear As Long
        Dim Folders As Outlook.Folders
        Dim mli As MailItem
        Dim nms As NameSpace
        Dim objAllItems As Outlook.Items
        Dim objAllItems2 As Outlook.Items
        Dim objFilteredItems As Outlook.Items
        Dim objItem As Object
        Dim strCriteria As String
        Dim xlsCriterio As String
        
        lngYear = InputBox("Digite o ano de pesquisa:", , Year(Date))
        lngMonth = InputBox("Digite o mês de pesquisa:", , Month(Date))
        
        
        If lngYear < 1900 Or lngYear > 3000 Or lngMonth < 1 Or lngMonth > 12 Then
            MsgBox "Dados de entrada incorretos.", vbCritical
            Exit Sub
        End If
        Set nms = Application.GetNamespace("MAPI")
        'Altere as pastas abaixo para como está configurado seu e-mail:
        Set objAllItems = nms.Folders("thiagovbacellar@eaton.com").Folders("Caixa de Entrada").Items
        
        strCriteria = "[ReceivedTime] > " & "'" & DateSerial(lngYear, lngMonth, 1) & "'" _
        & " And [ReceivedTime] < " & "'" & DateSerial(lngYear, lngMonth + 1, 1) & "'"
        Set objFilteredItems = objAllItems.Restrict(strCriteria)
        
        FF = FreeFile
        Open "C:\Users\e8760255\Desktop\Relatorio2.xls" For Output As #FF
        For Each objItem In objFilteredItems
            If TypeName(objItem) = "MailItem" Then
                Set mli = objItem
                
                'Print #FF, "Teste:" & mli.LastModificationTime
                
                
                xlsCriterio = "Emitente: " & mli.To & "|" & "Data Recebimento: " & mli.ReceivedTime & "|" & "Data Resposta: " & mli.SentOn & "|" & "Título: " & mli.Subject & "|" _
                & "ConversationID: " & mli.ConversationID & "|" & "ConversationIndex: " & mli.ConversationIndex & "|" & "Pasta: " & mli.Parent.Name
                'Print #FF, "Corpo da Mensagem: " & Left(mli.Body, 80)
          
          
          Print #FF, xlsCriterio
          
            End If
        Next objItem
        Close #FF
    End Sub
    Sub Parte2()
       
        
        Const cstrOutput As String = "\Desktop\Teste Outlook\Relatorio2.xls"
        Dim FF As Integer
        Dim lngMonth As Long
        Dim lngYear As Long
        Dim Folders As Outlook.Folders
        Dim mli As MailItem
        Dim nms As NameSpace
        Dim objAllItems As Outlook.Items
        Dim objFilteredItems As Outlook.Items
        Dim objItem As Object
        Dim strCriteria As String
        Dim xlsCriterio As String
        Dim cms As String
        
        lngYear = InputBox("Digite o ano de pesquisa:", , Year(Date))
        lngMonth = InputBox("Digite o mês de pesquisa:", , Month(Date))
        
        
        If lngYear < 1900 Or lngYear > 3000 Or lngMonth < 1 Or lngMonth > 12 Then
            MsgBox "Dados de entrada incorretos.", vbCritical
            Exit Sub
        End If
        Set nms = Application.GetNamespace("MAPI")
        'Altere as pastas abaixo para como está configurado seu e-mail:
        Set objAllItems = nms.Folders("thiagovbacellar@eaton.com").Folders("Mensagens Enviadas").Items
        
        strCriteria = "[ReceivedTime] > " & "'" & DateSerial(lngYear, lngMonth, 1) & "'" _
        & " And [ReceivedTime] < " & "'" & DateSerial(lngYear, lngMonth + 1, 1) & "'"
        Set objFilteredItems = objAllItems.Restrict(strCriteria)
        
        FF = FreeFile
        'Sheets.Add After:=Sheets(Sheets.Count)
        Open "C:\Users\e8760255\Desktop\Relatorio2.xls" For Output As #FF
        For Each objItem In objFilteredItems
            If TypeName(objItem) = "MailItem" Then
                Set mli = objItem
                xlsCriterio = "Emitente: " & mli.To & "|" & "Data Recebimento: " & mli.ReceivedTime & "|" & "Data Resposta: " & mli.SentOn & "|" & "Título: " & mli.Subject & "|" _
                & "ConversationID: " & mli.ConversationID & "|" & "ConversationIndex: " & mli.ConversationIndex & "|" & "Pasta: " & mli.Parent.Name
                'Print #FF, "Corpo da Mensagem: " & Left(mli.Body, 80)
          
          
          Print #FF, xlsCriterio
          
            End If
        Next objItem
        Close #FF
    End Sub

    Obrigado.
    segunda-feira, 28 de outubro de 2013 17:05
  • Thiago,

    Para salvar numa pasta de trabalho, você deverá criar uma instância do Excel.

    Veja detalhes em: http://www.ambienteoffice.com.br/excel/criar_uma_instancia_do_excel_pelo_vba/


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    segunda-feira, 28 de outubro de 2013 23:32
    Moderador
  • Olá Felipe!

    Será que você poderia me ajudar? Eu precisava de algo bem parecido com o que você passou para pessoa que criou esse tópico. Porém preciso que seja extraido todos os email recebidos, contendo a data de recebimento, é possível fazer algum alteração nesse mesmo código para que a macro extraia esse relatório?

    sexta-feira, 11 de agosto de 2017 17:03
  • Boa Tarde !

    Felipe,

    Sabe me dizer como eu teria que fazer para que fosse solicitado um intervalo de dias, ou alem do ano e mes ser solicitado o dia, para que ao ser executado o relatorio ele me traga os resultados referentes a somente um dia ou um intervalo solicitado na tela  ?

    segunda-feira, 23 de outubro de 2017 14:27