Importar dados do Outlook para txt,xls etc

Question

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

Answer 1

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("[e-mail]").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

Answer 2

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 recebimento / Departamento / 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.

Answer 3

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

Answer 4

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.

Answer 5

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

Answer 6

Bom dia e obrigado amigo.

quando executo o depurador critica na seguinte linha :

Set rcp = mli.Recipient(1).Resolve

Sabe o que poderia ser ?

Answer 7

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

Answer 8

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 & "|"
            

Answer 9

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

Answer 10

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.

Answer 11

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

Answer 12

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("[e-mail]").Folders("Caixa de Entrada").Items
    Set objAllItems2 = nms.Folders("[e-mail]").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.

Answer 13

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

Answer 14

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("[e-mail]").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("[e-mail]").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.

Answer 15

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

Answer 16

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?

Answer 17

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  ?