¿Puedo iterar a través de todos los correos electrónicos de Outlook en una carpeta que incluya subcarpetas?

Tengo una carpeta que contiene una cantidad de correos electrónicos y subcarpetas. Dentro de esas subcarpetas hay más correos electrónicos.

Me gustaría escribir algunos VBA que iterarán a través de todos los correos electrónicos en una determinada carpeta, incluidos aquellos en cualquiera de las subcarpetas. La idea es extraer SenderEmailAddress y SenderName de cada correo electrónico y hacer algo con él.

Intenté simplemente exportar la carpeta como CSV con solo estos dos campos y mientras esto funciona, no es compatible con la exportación de correos electrónicos en subcarpetas. De ahí la necesidad de escribir algunos VBA.

Antes de volver a inventar el volante, ¿alguien tiene fragmentos de código o enlaces a sitios que, con el nombre de una carpeta, muestran cómo obtener un objeto MailItem para cada correo electrónico en esa carpeta y subsiguientes subcarpetas?

Algo como esto …

  Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder) Dim oFolder As Outlook.MAPIFolder Dim oMail As Outlook.MailItem For Each oMail In oParent.Items 'Get your data here ... Next If (oParent.Folders.Count > 0) Then For Each oFolder In oParent.Folders processFolder oFolder Next End If End Sub 

Esto tiene un gran código que te interesa. Ve a ejecutarlo en Outlook / VBA como una macro.

 Const MACRO_NAME = "OST2XLS" Dim excApp As Object, _ excWkb As Object, _ excWks As Object, _ intVersion As Integer, _ intMessages As Integer, _ lngRow As Long Sub ExportMessagesToExcel() Dim strFilename As String, olkSto As Outlook.Store strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME) If strFilename <> "" Then intMessages = 0 intVersion = GetOutlookVersion() Set excApp = CreateObject("Excel.Application") Set excWkb = excApp.Workbooks.Add For Each olkSto In Session.Stores Set excWks = excWkb.Worksheets.Add() excWks.Name = "Output1" 'Write Excel Column Headers With excWks .Cells(1, 1) = "Folder" .Cells(1, 2) = "Sender" .Cells(1, 3) = "Received" .Cells(1, 4) = "Sent To" .Cells(1, 5) = "Subject" End With lngRow = 2 ProcessFolder olkSto.GetRootFolder() Next excWkb.SaveAs strFilename End If Set excWks = Nothing Set excWkb = Nothing excApp.Quit Set excApp = Nothing MsgBox "Process complete. A total of " & intMessages & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel" End Sub Sub ProcessFolder(olkFld As Outlook.MAPIFolder) Dim olkMsg As Object, olkSub As Outlook.MAPIFolder 'Write messages to spreadsheet 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(lngRow, 1) = olkFld.Name excWks.Cells(lngRow, 2) = GetSMTPAddress(olkMsg, intVersion) excWks.Cells(lngRow, 3) = olkMsg.ReceivedTime excWks.Cells(lngRow, 4) = olkMsg.ReceivedByName excWks.Cells(lngRow, 5) = olkMsg.Subject lngRow = lngRow + 1 intMessages = intMessages + 1 End If Next Set olkMsg = Nothing For Each olkSub In olkFld.Folders ProcessFolder olkSub Next Set olkSub = Nothing End Sub Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String Dim olkSnd As Outlook.AddressEntry, olkEnt As Object On Error Resume Next Select Case intOutlookVersion Case Is < 14 If Item.SenderEmailType = "EX" Then GetSMTPAddress = SMTP2007(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 SMTP2007(olkMsg As Outlook.MailItem) As String Dim olkPA As Outlook.PropertyAccessor On Error Resume Next Set olkPA = olkMsg.PropertyAccessor SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E") On Error GoTo 0 Set olkPA = Nothing End Function