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

Question

我试图将我的收件箱中的每封电子邮件（发件人，收到时间，主题等）的详细信息导入到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 

Answer 1

从这个问题Can I iterate through all Outlook emails in a folder including sub-folders?

替换您尝试遍历文件夹...

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