Usuário com melhor resposta
Importar dados do Outlook para txt,xls etc

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
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
- Editado Felipe Costa GualbertoMVP, Moderator quinta-feira, 12 de setembro de 2013 23:36
- Marcado como Resposta Hezequias VasconcelosModerator sexta-feira, 11 de outubro de 2013 16:11
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
-
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.
-
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
-
-
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
- Editado Felipe Costa GualbertoMVP, Moderator quinta-feira, 12 de setembro de 2013 23:36
- Marcado como Resposta Hezequias VasconcelosModerator sexta-feira, 11 de outubro de 2013 16:11
-
-
-
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 & "|"
-
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
-
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.
-
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
-
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. -
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
-
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. -
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
-
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?
-
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 ?