vba 我可以遍历文件夹（包括子文件夹）中的所有 Outlook 电子邮件吗？

Can I iterate through all Outlook emails in a folder including sub-folders?

提问by Richard

I have a folder which contains a number of emails and sub-folders. Within those sub-folders are more emails.

我有一个文件夹，其中包含许多电子邮件和子文件夹。在这些子文件夹中有更多的电子邮件。

I'd like to write some VBA which will iterate through all emails in a certain folder, including those in any of the sub-folders. The idea is to extract the SenderEmailAddressand SenderNamefrom every email and do something with it.

我想编写一些 VBA，它将遍历某个文件夹中的所有电子邮件，包括任何子文件夹中的电子邮件。这个想法是提取SenderEmailAddress并SenderName从每一个电子邮件，用它做什么。

I've tried just exporting the folder as CSV with only these two fields and whilst this works, it doesn't support exporting emails held in sub-folders. Hence the need to write some VBA.

我已经尝试将文件夹导出为仅包含这两个字段的 CSV 文件，虽然这有效，但它不支持导出子文件夹中保存的电子邮件。因此需要编写一些 VBA。

Before I go re-inventing the wheel, does anyone have any code snippets or links to sites which, given a folder name, shows how to get a MailItemobject for every email in that folder andsubsequent sub-folders?

在我重新发明轮子之前，有没有人有任何代码片段或站点链接，给定文件夹名称，显示如何MailItem为该文件夹和后续子文件夹中的每封电子邮件获取对象？

回答by 76mel

Something like this ...

像这样的东西...

 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

回答by Jonathan Morningstar

This has a lot of great code that you are interested in. Go run it in Outlook/VBA as a macro.

这有很多您感兴趣的很棒的代码。在 Outlook/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