Outlook VBA 将电子邮件从子文件夹导入 Excel [英] Outlook VBA Importing Emails from Subfolders into Excel
问题描述
我正在尝试将收件箱中每封电子邮件的详细信息(发件人、接收时间、主题等)导入到 Excel 文件中.我的代码适用于收件箱中的特定文件夹,但我的收件箱有几个子文件夹,这些子文件夹也有子文件夹.
I am trying to import details of every email (sender, received time, subject etc.) in my Inbox into an Excel file. I have code that works fine for a specific folder within the Inbox but my Inbox has several subfolders, and these subfolders also have subfolders.
经过多次反复试验,我设法导入了收件箱下所有子文件夹的详细信息.但是,该代码不会从第二层子文件夹导入电子邮件,并且还会跳过仍在收件箱中的电子邮件.我已经搜索了这个网站和其他网站,但找不到循环浏览收件箱的所有文件夹和子文件夹的代码.
After much trial and error I have managed to import details of all subfolders under the Inbox. However the code does not import the emails from the 2nd tier of subfolders and it also skips the emails that are still in the Inbox itself. I have searched this site and others but cannot find the code to loop through all folders and subfolders of an Inbox.
例如,我有一个包含子文件夹报告、定价和项目的收件箱.报告子文件夹包含名为 Daily、Weekly 和 Monthly 的子文件夹.我可以在报告中导入电子邮件,但不能在每日、每周和每月导入.
For example I have an Inbox with subfolders Reports, Pricing and Projects. The Report subfolder has subfolders called Daily, Weekly and Monthly. I can import the emails in Reports but not in Daily, Weekly and 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
推荐答案
来自这个问题 我可以遍历一个文件夹中的所有 Outlook 电子邮件,包括子文件夹吗?
替换您对文件夹进行迭代的尝试...
Replace your attempt to iterate the 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
...使用当前接受的答案中描述的递归思想.
...using the idea of recursion described in the currently accepted answer.
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
充实的第二个答案展示了如何在代码之外声明变量以传递值.
The fleshed out second answer shows how to declare variables outside of the code to pass values.
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
这篇关于Outlook VBA 将电子邮件从子文件夹导入 Excel的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!