我可以遍歷包含子文件夾的文件夾中的所有Outlook電子郵件嗎？

Question

我有一個文件夾，其中包含一些電子郵件和子文件夾。在這些子文件夾中有更多的電子郵件。

我想寫一些VBA，它將遍歷某個文件夾中的所有電子郵件，包括任何子文件夾中的電子郵件。我們的想法是從每封電子郵件中提取SenderEmailAddress和SenderName，並對其進行處理。

我試過只導出文件夾爲CSV只有這兩個字段，雖然這個工程，它不支持導出保存在子文件夾中的電子郵件。因此需要編寫一些VBA。

之前，我去重新發明輪子，沒有任何人有任何的代碼段或鏈接到網站針對指定的文件夾名稱，顯示瞭如何獲得一個MailItem對象爲該文件夾和隨後的子文件夾中的每一封電子郵件？

Answer 1

事情是這樣的......

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

這有很多偉大的代碼，你有興趣，去展望/ VBA運行宏。

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