Posso scorrere tutte le email di Outlook in una cartella comprese le sottocartelle?

Ho una cartella che contiene un numero di e-mail e sottocartelle. All’interno di queste sottocartelle ci sono più e-mail.

Mi piacerebbe scrivere qualche VBA che eseguirà l’iterazione di tutte le e-mail in una determinata cartella, comprese quelle in una delle sottocartelle. L’idea è di estrarre SenderEmailAddress e SenderName da ogni e-mail e fare qualcosa con esso.

Ho provato solo ad esportare la cartella come CSV con solo questi due campi e mentre questo funziona, non supporta l’esportazione di e-mail conservati in sottocartelle. Da qui la necessità di scrivere alcuni VBA.

Prima di reinventare la ruota, qualcuno ha qualche frammento di codice o link a siti che, dato il nome di una cartella, mostra come ottenere un object MailItem per ogni email in quella cartella e nelle successive sottocartelle?

Qualcosa come questo …

  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 

Questo ha un grande codice che ti interessa. Vai in Outlook / VBA come 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