Outlook VBA 将电子邮件从子文件夹导入 Excel

我正在尝试将收件箱中每封电子邮件的详细信息（发件人、接收时间、主题等）导入到 Excel 文件中。我的代码适用于收件箱中的特定文件夹，但我的收件箱有几个子文件夹，并且这些子文件夹也有子文件夹。

经过多次尝试和错误，我成功导入了收件箱下所有子文件夹的详细信息。但是，该代码不会从第二层子文件夹导入电子邮件，并且还会跳过仍在收件箱本身中的电子邮件。我已搜索此网站和其他网站，但找不到循环遍历收件箱的所有文件夹和子文件夹的代码。

例如，我有一个包含子文件夹“报告”、“定价”和“项目”的收件箱。 报告子文件夹包含名为“每日”、“每周”和“每月”的子文件夹。我可以导入报告中的电子邮件，但不能导入每日、每周和每月中的电子邮件。

我的代码如下：

Sub SubFolders()

Dim olMail As Variant
Dim aOutput() As Variant
Dim lCnt As Long
Dim xlSh As Excel.Worksheet
Dim olApp As Outlook.Application
Dim olNs As Folder
Dim olParentFolder As Outlook.MAPIFolder
Dim olFolderA As Outlook.MAPIFolder
Dim olFolderB As Outlook.MAPIFolder

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

Set olParentFolder = olNs
ReDim aOutput(1 To 100000, 1 To 5)

For Each olFolderA In olParentFolder.Folders
    For Each olMail In olFolderA.Items
    If TypeName(olMail) = "MailItem" Then
    On Error Resume Next
        lCnt = lCnt + 1
        aOutput(lCnt, 1) = olMail.SenderEmailAddress
        aOutput(lCnt, 2) = olMail.ReceivedTime
        aOutput(lCnt, 3) = olMail.Subject
        aOutput(lCnt, 4) = olMail.Sender
        aOutput(lCnt, 5) = olMail.To

    End If
    Next
Next

Set xlApp = New Excel.Application
Set xlSh = xlApp.Workbooks.Add.Sheets(1)

xlSh.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
xlApp.Visible = True

End Sub

从这个问题我可以遍历文件夹（包括子文件夹）中的所有 Outlook 电子邮件吗？

替换您迭代文件夹的尝试...

For Each olFolderA In olParentFolder.Folders
    For Each olMail In olFolderA.Items
    If TypeName(olMail) = "MailItem" Then
    On Error Resume Next
        lCnt = lCnt + 1
        aOutput(lCnt, 1) = olMail.SenderEmailAddress
        aOutput(lCnt, 2) = olMail.ReceivedTime
        aOutput(lCnt, 3) = olMail.Subject
        aOutput(lCnt, 4) = olMail.Sender
        aOutput(lCnt, 5) = olMail.To
    End If
    Next
Next

...使用当前接受的答案中描述的递归思想。

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   ' <--- no brackets around oFolder
        Next
    End If
End Sub

充实的第二个答案展示了如何在代码外部声明变量以传递值。

Option Explicit

Dim aOutput() As Variant
Dim lCnt As Long

Sub SubFolders()
'
' Code for Outlook versions 2007 and subsequent
' Declare with Folder rather than MAPIfolder
'
Dim xlApp As Excel.Application
Dim xlSh As Excel.Worksheet

Dim olNs As Namespace
Dim olParentFolder As Folder

Set olNs = GetNamespace("MAPI")
Set olParentFolder = olNs.GetDefaultFolder(olFolderInbox)

lCnt = 0
ReDim aOutput(1 To 100000, 1 To 5)

ProcessFolder olParentFolder

On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
On Error GoTo 0
If xlApp Is Nothing Then Set xlApp = CreateObject("Excel.Application")

Set xlSh = xlApp.Workbooks.Add.Sheets(1)

xlSh.range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
xlApp.Visible = True

ExitRoutine:
    Set olNs = Nothing
    Set olParentFolder = Nothing
    Set xlApp = Nothing
    Set xlSh = Nothing

End Sub

Private Sub ProcessFolder(ByVal oParent As Folder)

Dim oFolder As Folder
Dim oMail As Object

For Each oMail In oParent.Items

    If TypeName(oMail) = "MailItem" Then
        lCnt = lCnt + 1
        aOutput(lCnt, 1) = oMail.SenderEmailAddress
        aOutput(lCnt, 2) = oMail.ReceivedTime
        aOutput(lCnt, 3) = oMail.Subject
        aOutput(lCnt, 4) = oMail.Sender
        aOutput(lCnt, 5) = oMail.To
    End If

Next

If (oParent.Folders.count > 0) Then
    For Each oFolder In oParent.Folders
        ProcessFolder oFolder
    Next
End If

End Sub