¿Puedo repetir todos los correos electrónicos de Outlook en una carpeta que incluya subcarpetas?

Question

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 recorrerán todos los correos electrónicos en una determinada carpeta, incluidos los de cualquiera de las subcarpetas. La idea es extraer el SenderEmailAddress y SenderName de cada correo electrónico y hacer algo con él.

He tratado de 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 ir a reinventar la rueda, ¿alguien tiene alguna fragmentos de código o enlaces a sitios que, dado un nombre de carpeta, se muestra cómo obtener un objeto MailItem para todos los correos electrónicos en esa carpeta y posteriores subcarpetas ?

Answer 1

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 

Answer 2

Esto tiene un montón de gran código que le 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