Posso iterar todos os emails do Outlook em uma pasta, incluindo subpastas?

Eu tenho uma pasta que contém vários emails e subpastas. Dentro dessas subpastas há mais e-mails.

Eu gostaria de escrever algum VBA que irá percorrer todos os e-mails em uma determinada pasta, incluindo aqueles em qualquer uma das subpastas. A idéia é extrair o SenderEmailAddress e SenderName de cada email e fazer algo com ele.

Eu tentei apenas exportar a pasta como CSV com apenas esses dois campos e, embora isso funcione, ele não suporta a exportação de emails contidos em subpastas. Daí a necessidade de escrever algum VBA.

Antes de eu reinventar a roda, alguém tem algum trecho de código ou links para sites que, dado o nome de uma pasta, mostra como obter um object MailItem para cada e-mail dessa pasta e subpastas subseqüentes?

Algo assim …

  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 

Isso tem um monte de código grande que você está interessado. Vá executá-lo no Outlook / VBA como uma 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 
Intereting Posts