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

Question

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

Vorrei scrivere un VBA che eseguirà l'iterazione di tutte le e-mail in una determinata cartella, comprese quelle in una delle sottocartelle. L'idea è di estrarre il SenderEmailAddress e il 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 andare re-inventare la ruota, qualcuno ha qualche frammenti di codice o link a siti che, dato un nome di cartella, mostra come ottenere un oggetto MailItem per ogni e-mail nella cartella e successive sottocartelle ?

Answer 1

qualcosa di simile ...

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

Questo ha un sacco di grande codice che si interessa. Andare a correre in Outlook/VBA come 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