Outlook VBA 將電子郵件從子文件夾導入 Excel

Question

我正在嘗試將收件箱中每封電子郵件的詳細信息（發件人、接收時間、主題等）導入到 Excel 文件中。 我的代碼適用於收件箱中的特定文件夾，但我的收件箱有幾個子文件夾，這些子文件夾也有子文件夾。

經過多次反復試驗，我設法導入了收件箱下所有子文件夾的詳細信息。 但是，該代碼不會從第二層子文件夾導入電子郵件，並且還會跳過仍在收件箱中的電子郵件。 我搜索了這個網站和其他網站，但找不到代碼來循環瀏覽收件箱的所有文件夾和子文件夾。

例如，我有一個包含子文件夾報告、定價和項目的收件箱。 報告子文件夾包含名為 Daily、Weekly 和 Monthly 的子文件夾。 我可以在 Reports 中導入電子郵件，但不能在 Daily、Weekly 和 Monthly 中導入。

我的代碼如下：

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

Answer 1

從這個問題我可以遍歷文件夾中的所有 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