Note: The other languages of the website are Google-translated. Back to English

Como exportar e-mails de várias pastas / subpastas para o Excel no Outlook?

Ao exportar uma pasta com o assistente de Importação e Exportação no Outlook, ele não oferece suporte ao Incluir subpastas opção se você exportar a pasta para um arquivo CSV. No entanto, será muito demorado e tedioso exportar cada pasta para um arquivo CSV e, em seguida, convertê-lo para uma pasta de trabalho do Excel manualmente. Aqui, este artigo apresentará um VBA para exportar rapidamente várias pastas e subpastas para pastas de trabalho do Excel com facilidade.

Exporte vários e-mails de várias pastas / subpastas para o Excel com VBA

Guia Office - Habilite a edição e navegação com guias no Office e torne o trabalho muito mais fácil ...
Kutools for Outlook - traz 100 recursos avançados poderosos para o Microsoft Outlook
  • Auto CC / BCC por regras ao enviar e-mail; Avanço automático Vários e-mails por regras; Resposta automatica sem servidor Exchange e mais recursos automáticos ...
  • Aviso BCC - mostrar mensagem quando você tenta responder a todos se o seu endereço de e-mail estiver na lista BCC; Lembrar quando houver anexos ausentes, e mais recursos de lembrete ...
  • Responder (todos) com todos os anexos na conversa de correio; Responder muitos e-mails de uma vez; Adicionar saudação automaticamente quando responder; Adicionar data e hora automaticamente ao assunto ...
  • Ferramentas de Anexo: Desanexar automaticamente, Comprimir tudo, Renomear tudo, Salvar tudo automaticamente ... Relatório Rápido, Contar e-mails selecionados, Remover e-mails e contatos duplicados ...
  • Mais de 100 recursos avançados resolva a maioria dos seus problemas no Outlook 2010-2019 e 365. Full features 60-day free trial.

seta azul bolha direita Exporte vários e-mails de várias pastas / subpastas para o Excel com VBA

Siga as etapas abaixo para exportar e-mails de várias pastas ou subpastas para pastas de trabalho do Excel com VBA no Outlook.

1. Pressione outro + F11 para abrir a janela Microsoft Visual Basic for Applications.

2. Clique inserção > Móduloe, em seguida, cole o código VBA abaixo na nova janela do módulo.

VBA: Exportar e-mails de várias pastas e subpastas para o Excel

Const MACRO_NAME = "Export Outlook Folders to Excel"

Sub ExportMain()
ExportToExcel "destination_folder_path\A.xlsx", "your_email_accouny\folder\subfolder_1"
ExportToExcel "destination_folder_path\B.xlsx", "your_email_accouny\folder\subfolder_2"
MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub
Sub ExportToExcel(strFilename As String, strFolderPath As String)
Dim      olkMsg As Object
Dim olkFld As Object
Dim excApp As Object
Dim excWkb As Object
Dim excWks As Object
Dim intRow As Integer
Dim intVersion As Integer

If strFilename <> "" Then
If strFolderPath <> "" Then
Set olkFld = OpenOutlookFolder(strFolderPath)
If TypeName(olkFld) <> "Nothing" Then
intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.ActiveSheet
'Write Excel Column Headers
With excWks
.Cells(1, 1) = "Subject"
.Cells(1, 2) = "Received"
.Cells(1, 3) = "Sender"
End With
intRow = 2
For Each olkMsg In olkFld.Items
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.Class = olMail Then
'Add a row for each field in the message you want to export
excWks.Cells(intRow, 1) = olkMsg.Subject
excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
intRow = intRow + 1
End If
Next
Set olkMsg = Nothing
excWkb.SaveAs strFilename
excWkb.Close
Else
MsgBox "The folder '" & strFolderPath & "' does not exist in Outlook.", vbCritical + vbOKOnly, MACRO_NAME
End If
Else
MsgBox "The folder path was empty.", vbCritical + vbOKOnly, MACRO_NAME
End If
Else
MsgBox "The filename was empty.", vbCritical + vbOKOnly, MACRO_NAME
End If

Set olkMsg = Nothing
Set olkFld = Nothing
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
End Sub

Public Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
Dim arrFolders As Variant
Dim varFolder As Variant
Dim bolBeyondRoot As Boolean

On Error Resume Next
If strFolderPath = "" Then
Set OpenOutlookFolder = Nothing
Else
Do While Left(strFolderPath, 1) = "\"
strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
Loop
arrFolders = Split(strFolderPath, "\")
For Each varFolder In arrFolders
Select Case bolBeyondRoot
Case False
Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
bolBeyondRoot = True
Case True
Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
End Select
If Err.Number <> 0 Then
Set OpenOutlookFolder = Nothing
Exit For
End If
Next
End If
On Error GoTo 0
End Function

Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry
Dim olkEnt As Object

On Error Resume Next
Select Case intOutlookVersion
Case Is < 14
If Item.SenderEmailType = "EX" Then
GetSMTPAddress = SMTPEX(Item)
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
Case Else
Set olkSnd = Item.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkEnt = olkSnd.GetExchangeUser
GetSMTPAddress = olkEnt.PrimarySmtpAddress
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
End Select
On Error GoTo 0
Set olkPrp = Nothing
Set olkSnd = Nothing
Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
Dim arrVer As Variant
arrVer = Split(Outlook.Version, ".")
GetOutlookVersion = arrVer(0)
End Function

Function SMTPEX(olkMsg As Outlook.MailItem) As String
Dim olkPA As Outlook.propertyAccessor
On Error Resume Next
Set olkPA = olkMsg.propertyAccessor
SMTPEX = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
On Error GoTo 0
Set olkPA = Nothing
End Function

3. Ajuste o código VBA acima conforme necessário.

(1) Substituir destino_pasta_caminho no código acima com o caminho da pasta de destino em que você salvará as pastas de trabalho exportadas, como C: \ Users \ DT168 \ Documents \ TEST.
(2) Substitua your_email_accouny \ folder \ subfolder_1 e your_email_accouny \ folder \ subfolder_2 no código acima pelos caminhos de pasta de subpastas no Outlook, como Kelly @extendoffice.com \ Inbox \ A e Kelly @extendoffice.com \ Inbox \ B

4. aperte o F5 ou clique no Corrida botão para executar este VBA. E então clique no OK na caixa de diálogo Exportar Pastas do Outlook para Excel. Veja a imagem:

E agora os e-mails de todas as subpastas ou pastas especificadas no código VBA acima são exportados e salvos em pastas de trabalho do Excel.


seta azul bolha direitaArtigos Relacionados


Kutools for Outlook - traz 100 recursos avançados para o Outlook e torna o trabalho muito mais fácil!

  • Auto CC / BCC por regras ao enviar e-mail; Avanço automático Vários emails por encomenda; Resposta automatica sem servidor Exchange e mais recursos automáticos ...
  • Aviso BCC - mostrar mensagem quando você tentar responder a todos se o seu endereço de e-mail estiver na lista BCC; Lembrar quando houver anexos ausentes, e mais recursos de lembrete ...
  • Responder (todos) com todos os anexos na conversa de correio; Responder muitos e-mails em segundos; Adicionar saudação automaticamente quando responder; Adicionar data ao assunto ...
  • Ferramentas de anexo: gerenciar todos os anexos em todos os e-mails, Desanexação Automática, Comprimir tudo, Renomear tudo, Salvar tudo ... Relatório rápido, Contar e-mails selecionados...
  • Lixo eletrônico poderoso por costume; Remover e-mails e contatos duplicados... Permite que você faça de maneira mais inteligente, rápida e melhor no Outlook.
tiro kutools aba kutools do outlook 1180x121
tiro kutools outlook kutools mais guia 1180x121
 
Comentários (10)
Ainda não há classificações. Seja o primeiro a avaliar!
Este comentário foi feito pelo moderador no site
Como faço para que isso seja recursivo automaticamente em subpastas?
Este comentário foi feito pelo moderador no site
Olá queridos, tudo funcionando bem, muito obrigado, mas o corpo não é exportado, como posso exportar o corpo do e-mail também, o arquivo excel acabou de (Assunto, Recebido e Remetente), se você puder me atualizar com ele, resolverá um grande problema no meu negócio muito obrigado novamente
Este comentário foi feito pelo moderador no site
Olá Montaser,
O script VBA é executado com base no recurso Exportar do Outlook, que não oferece suporte à exportação de conteúdo de mensagens ao exportar emails em massa de uma pasta de email. Portanto, esse script VBA também não pode exportar o conteúdo da mensagem.
Este comentário foi feito pelo moderador no site
isso funciona muito bem, mas existe uma maneira de adicionar as informações não apenas para os 4 campos acima, mas tudo o que o Outlook exporta para PST fornece? Corpo do assunto De: (Nome) De: (Endereço) De: (Tipo) Para: (Nome) Para: (Endereço) Para: (Tipo) CC: (Nome) CC: (Endereço) CC: (Tipo) Cco: ( Nome) BCC: (Endereço) BCC: (Tipo) Categorias de informações de cobrança Importância Sensibilidade da milhagem

Tentei adicionar "Importância" e funcionou, mas agradeceria se alguém pudesse fornecer o código para os outros campos. obrigada!!
Com excWks
.Cells(1, 1) = "Assunto"
.Cells(1, 2) = "Recebido"
.Cells(1, 3) = "Remetente"
.Cells(1, 4) = "Corpo"
.Cells(1, 5) = "Importância"
Terminar com
intLinha = 2
Para cada olkMsg em olkFld.Items
'Exportar apenas mensagens, não recibos ou solicitações de agendamento, etc.
Se olkMsg.Class = olMail Então
'Adicione uma linha para cada campo na mensagem que você deseja exportar
excWks.Cells(intRow, 1) = olkMsg.Assunto
excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
excWks.Cells(intRow, 4) = olkMsg.Body
excWks.Cells(intRow, 5) = olkMsg.Importance
Este comentário foi feito pelo moderador no site
Olá, verifique o código abaixo para suas necessidades:
Const MACRO_NAME = "Exportar pastas do Outlook para Excel"

Sub ExportMain()

ExportToExcel "destination_folder_path\A.xlsx", "your_email_accouny\folder\subfolder_1"

ExportToExcel "destination_folder_path\B.xlsx", "your_email_accouny\folder\subfolder_2"

MsgBox "Processo concluído.", vbInformation + vbOKOnly, MACRO_NAME

End Sub

Sub ExportToExcel(strFilename As String, strFolderPath As String)

Dim olkMsg como objeto

Dim olkFld As Object

Dim excApp como objeto

Dim excWkb como objeto

Dim excWks como objeto

Dim intRow As Integer

Dim intVersion As Integer

If strFilename <> "" Então

If strFolderPath <> "" Então

Definir olkFld = OpenOutlookFolder(strFolderPath)

If TypeName(olkFld) <> "Nada" Then

intVersion = GetOutlookVersion()

Set excApp = CreateObject("Excel.Application")

Definir excWkb = excApp.Workbooks.Add()

Definir excWks = excWkb.ActiveSheet

'Escrever cabeçalhos de coluna do Excel

Com excWks

.Cells(1, 1) = "Assunto"

.Cells(1, 2) = "Corpo"

.Cells(1, 3) = "Recebido"

.Cells(1, 4) = "De: (Nome)"

.Cells(1, 5) = "De: (Endereço)"

.Cells(1, 6) = "De: (Tipo)"

.Cells(1, 7) = "Para: (Nome)"

.Cells(1, 8) = "Para: (Endereço)"

.Cells(1, 9) = "Para: (Tipo)"

.Cells(1, 10) = "CC: (Nome)"

.Cells(1, 11) = "CC: (Endereço)"

.Cells(1, 12) = "CC: (Tipo)"

.Cells(1, 13) = "BCC: (Nome)"

.Cells(1, 14) = "BCC: (Endereço)"

.Cells(1, 15) = "BCC: (Tipo)"

.Cells(1, 16) = "Informações de cobrança"

.Cells(1, 17) = "Categorias"

.Cells(1, 18) = "Importância"

.Cells(1, 19) = "Milhagem"

.Cells(1, 20) = "Sensibilidade"

Terminar com

intLinha = 2

Para cada olkMsg em olkFld.Items

'Exportar apenas mensagens, não recibos ou solicitações de agendamento, etc.

Se olkMsg.Class = olMail Então

'Adicione uma linha para cada campo na mensagem que você deseja exportar

excWks.Cells(intRow, 1) = olkMsg.Assunto

excWks.Cells(intRow, 2) = olkMsg.Body

excWks.Cells(intRow, 3) = olkMsg.ReceivedTime

excWks.Cells(intRow, 4) = olkMsg.SenderName

excWks.Cells(intRow, 5) = GetAddress(olkMsg.Sender, intVersion)

excWks.Cells(intRow, 6) = olkMsg.Sender.Type

excWks.Cells(intRow, 7) = GetRecipientsName(olkMsg, 1, 1, intVersion)

excWks.Cells(intRow, 8) = GetRecipientsName(olkMsg, 1, 2, intVersion)

excWks.Cells(intRow, 9) = GetRecipientsName(olkMsg, 1, 3, intVersion)

excWks.Cells(intRow, 10) = GetRecipientsName(olkMsg, 2, 1, intVersion)

excWks.Cells(intRow, 11) = GetRecipientsName(olkMsg, 2, 2, intVersion)

excWks.Cells(intRow, 12) = GetRecipientsName(olkMsg, 2, 3, intVersion)

excWks.Cells(intRow, 13) = GetRecipientsName(olkMsg, 3, 1, intVersion)

excWks.Cells(intRow, 14) = GetRecipientsName(olkMsg, 3, 2, intVersion)

excWks.Cells(intRow, 15) = GetRecipientsName(olkMsg, 3, 3, intVersion)

excWks.Cells(intRow, 16) = olkMsg.BillingInformation

excWks.Cells(intRow, 17) = olkMsg.Categories

excWks.Cells(intRow, 18) = olkMsg.Importance

excWks.Cells(intRow, 19) = olkMsg.Mileage

excWks.Cells(intRow, 20) = olkMsg.Sensitivity

intLinha = intLinha + 1

Se acabar

Seguinte

Definir olkMsg = Nada

excWkb.SaveAs strFilename

excWkb.Fechar

Outro

MsgBox "A pasta '" & strFolderPath & "' não existe no Outlook.", vbCritical + vbOKOnly, MACRO_NAME

Se acabar

Outro

MsgBox "O caminho da pasta estava vazio.", vbCritical + vbOKOnly, MACRO_NAME

Se acabar

Outro

MsgBox "O nome do arquivo estava vazio.", vbCritical + vbOKOnly, MACRO_NAME

Se acabar



Definir olkMsg = Nada

Definir olkFld = Nada

Definir excWks = Nada

Definir excWkb = Nada

Definir excApp = Nada

End Sub



Função pública OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder

Dim arrFolders como variante

Dim varFolder como variante

Dim bolBeyondRoot como booleano

On Error Resume Next

Se strFolderPath = "" Então

Definir OpenOutlookFolder = Nada

Outro

Faça Enquanto Esquerda(strFolderPath, 1) = "\"

strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)

laço

arrFolders = Split(strFolderPath, "\")

Para cada varFolder Em arrFolders

Selecione maiúsculas e minúsculas bolBeyondRoot

Caso Falso

Definir OpenOutlookFolder = Outlook.Session.Folders(varFolder)

bolBeyondRoot = Verdadeiro

Caso Verdadeiro

Definir OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)

End Select

If Err.Number <> 0 Then

Definir OpenOutlookFolder = Nada

Sair para

Se acabar

Seguinte

Se acabar

Em erro GoTo 0

Função final



Função GetOutlookVersion() como inteiro

Dim arrVer como variante

arrVer = Split(Outlook.Version, ".")

GetOutlookVersion = arrVer(0)

Função final



Função SMTPEX(Entrada como EndereçoEntrada) Como String

Dim olkPA como Outlook.PropertyAccessor

On Error Resume Next

Defina olkPA = Entry.PropertyAccessor

SMTPEX = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")

Em erro GoTo 0

Definir olkPA = Nada

Função final



Função GetAddress(Entrada como AddressEntry, intOutlookVersion As Integer) As String

Dim olkEnt As Object

On Error Resume Next

Selecionar caso intOutlookVersion

Caso é < 14

Se Entry.Type = "EX" Then

GetAddress = SMTPEX(Entrada)

Outro

GetAddress = Entry.Address

Se acabar

Case Else

Se Entry.AddressEntryUserType = olExchangeUserAddressEntry Então

Defina olkEnt = Entry.GetExchangeUser

GetAddress = olkEnt.PrimarySmtpAddress

Outro

GetAddress = Entry.Address

Se acabar

End Select

Em erro GoTo 0

Definir olkEnt = Nada

Função final



Função GetRecipientsName(Item As MailItem, rcpType As Integer, Ret As Integer, intOutlookVersion As Integer) As String

Dim xRcp como destinatário

Dim xNames As String

xNomes = ""

Para cada xRcp no item. Destinatários

Se xRcp.Type = rcpType Então

Se Ret = 1 Então

Se xNames = "" Então

xNomes = xRcp.Nome

Outro

xNames = xNames & "; " & xRcp.Name

Se acabar

ElseIf Ret = 2 Então

Se xNames = "" Então

xNames = GetAddress(xRcp.AddressEntry, intOutlookVersion)

Outro

xNames = xNames & "; " & GetAddress(xRcp.AddressEntry, intOutlookVersion)

Se acabar

ElseIf Ret = 3 Então

Se xNames = "" Então

xNames = xRcp.AddressEntry.Type

Outro

xNames = xNames & "; " & xRcp.AddressEntry.Type

Se acabar

Se acabar

ElseIf xRcp.Type = rcpType Then

Se Ret = 1 Então

Se xNames = "" Então

xNomes = xRcp.Nome

Outro

xNames = xNames & "; " & xRcp.Name

Se acabar

ElseIf Ret = 2 Então

Se xNames = "" Então

xNames = GetAddress(xRcp.AddressEntry, intOutlookVersion)

Outro

xNames = xNames & "; " & GetAddress(xRcp.AddressEntry, intOutlookVersion)

Se acabar

ElseIf Ret = 3 Então

Se xNames = "" Então

xNames = xRcp.AddressEntry.Type

Outro

xNames = xNames & "; " & xRcp.AddressEntry.Type

Se acabar

Se acabar

ElseIf xRcp.Type = rcpType Then

Se Ret = 1 Então

Se xNames = "" Então

xNomes = xRcp.Nome

Outro

xNames = xNames & "; " & xRcp.Name

Se acabar

ElseIf Ret = 2 Então

Se xNames = "" Então

xNames = GetAddress(xRcp.AddressEntry, intOutlookVersion)

Outro

xNames = xNames & "; " & GetAddress(xRcp.AddressEntry, intOutlookVersion)

Se acabar

ElseIf Ret = 3 Então

Se xNames = "" Então

xNames = xRcp.AddressEntry.Type

Outro

xNames = xNames & "; " & xRcp.AddressEntry.Type

Se acabar

Se acabar

Se acabar

Seguinte

GetRecipientsName = xNomes

Função final




Espero que funcione para voce.
Amanda
Este comentário foi feito pelo moderador no site
No sub ExporttoExcel você pode adicionar o corpo

'Escrever cabeçalhos de coluna do Excel
Com excWks
.Cells(1, 1) = "Assunto"
.Cells(1, 2) = "Recebido"
.Cells(1, 3) = "Remetente"
.Cells(1, 4) = "Corpo"
Terminar com
intLinha = 2
Para cada olkMsg em olkFld.Items
'Exportar apenas mensagens, não recibos ou solicitações de agendamento, etc.
Se olkMsg.Class = olMail Então
'Adicione uma linha para cada campo na mensagem que você deseja exportar
excWks.Cells(intRow, 1) = olkMsg.Assunto
excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
excWks.Cells(intRow, 4) = olkMsg.Body
intLinha = intLinha + 1
Este comentário foi feito pelo moderador no site
Oi, Espero que alguém possa me ajudar aqui, eu praticamente não tenho conhecimento de VB, mas consegui fazer esse script funcionar para mim até agora.

No entanto, tenho cerca de 1500 pastas e subpastas na minha caixa de entrada no total e gostaria muito de um script simples para exportar todo o endereço de e-mail que enviei com a linha de assunto e a data em colunas separadas no Excel.

Eu procurei por dias e tentei muitos sites diferentes, mas não consigo fazer nenhum código funcionar além deste.


O que estou pedindo é mesmo possível? Se sim, há alguém por aí gentil e inteligente o suficiente para me ajudar com o script que eu preciso?
Presumo que tenha algo a ver com esta parte:


Sub ExportMain()

ExportToExcel "destination_folder_path\A.xlsx", "your_email_accouny\folder\subfolder_1"

ExportToExcel "destination_folder_path\B.xlsx", "your_email_accouny\folder\subfolder_2"

MsgBox "Processo concluído.", vbInformation + vbOKOnly, MACRO_NAME

End Sub


Graças, em avançado
Este comentário foi feito pelo moderador no site
Oi,
Acabei de executar esta macro que funciona bem.
Eu entendo isso nas expressões
excWks.Cells(intRow, 1) = olkMsg.Assunto
excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)

o olkMsg.* e GetSMTPAddress(olkMsg, intVersion) extraem coisas do Outlook.

Qual é o argumento a ser usado para obter o endereço para o qual o email foi enviado?

Ao usar o Assistente de Exportação do Outlook, é possível exportar este endereço, então suponho que seria possível fazê-lo através desta Macro (com alguma modificação).
Alguém pode ajudar?

Saudações
Este comentário foi feito pelo moderador no site
Eu corro esta macro, mas continuo recebendo erro de compilação:

Tipo definido pelo usuário não definido

Na linha 62 " Função pública OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder "

Já especifiquei o caminho da seguinte forma:

ExportToExcel "C:\Users\kudus\Documents\MailExportTest\f1\A.xlsx", "myname@mydomain.com\Inbox\Black Hat Webcast"
ExportToExcel "C:\Users\\Documekudus\Documents\MailExportTest\f2\B.xlsx", "myname@mydomain.com\Inbox\CPD\Kaplan Training"

Estou usando o Outlook 2016 caso seja necessário
Este comentário foi feito pelo moderador no site
Eu consertei isso. Na janela do visual basic, vá para Tools Reference - e a caixa para "Microsoft Outlook 16.0 Object Library"

Não há comentários postados aqui ainda
Deixe o seu comentário
Postando como convidado
×
Avalie esta postagem:
0   Personagens
Locais sugeridos