vba 从 Outlook 文件夹中提取电子邮件数据

Extract Email Data from Outlook Folder

提问by FV92

Working on an Excel Macro to go into a specified folder in Outlook and based on a variable (value/named range in Excel) extract data from emails (To, Subject, etc.).

使用 Excel 宏进入 Outlook 中的指定文件夹，并根据变量（Excel 中的值/命名范围）从电子邮件（收件人、主题等）中提取数据。

I cannot get it to extract anything besides the "Subject" and "Size" data of the emails.

除了电子邮件的“主题”和“大小”数据之外，我无法提取任何内容。

If I try to pull in the "To" data for example using the same method as the "Subject" or "Size" coding, then it comes up with

例如，如果我尝试使用与“主题”或“大小”编码相同的方法提取“收件人”数据，则会出现

"Run-time error '438': Object doesn't support this property or method error.

“运行时错误‘438’：对象不支持此属性或方法错误。

Sub FetchEmailData()

Dim appOutlook As Object
Dim olNs As Object
Dim olFolder As Object
Dim olItem As Object
Dim iRow As Integer

'Get/create Outlook Application
On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
If appOutlook Is Nothing Then
    Set appOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0

Set olNs = appOutlook.GetNamespace("MAPI")
Set olFolder = olNs.Folders("Mailbox_name").Folders("Inbox").Folders("XYZ").Folders("2017").Folders("04. April").Folders("Etc")

'Clear
ThisWorkbook.Sheets("Test").Cells.Delete

'Build headings:
ThisWorkbook.Sheets("Test").Range("A1:D1") = Array("Sender_Email_Address", "Subject", "To", "Size")

For iRow = 1 To olFolder.Items.Count
    ThisWorkbook.Sheets("Test").Cells(iRow, 1).Select
    'ThisWorkbook.Sheets("Test").Cells(iRow, 1) = olFolder.Items.Item(iRow).SenderEmailAddress
    ThisWorkbook.Sheets("Test").Cells(iRow, 2) = olFolder.Items.Item(iRow).Subject
    'ThisWorkbook.Sheets("Test").Cells(iRow, 3) = olFolder.Items.Item(iRow).To
    ThisWorkbook.Sheets("Test").Cells(iRow, 4) = olFolder.Items.Item(iRow).Size
Next iRow

End Sub

How could I extract email fields such as "From" and "To"?

如何提取“发件人”和“收件人”等电子邮件字段？

Also, if my Set olFoldervalue is a named range in Excel that dynamically changes with the date (=Today()) and uses Folder_Locationas the named range in Excel, would it be correct to write;

另外，如果我的Set olFolder值是 Excel 中的命名范围，该范围随日期 ( =Today())动态变化并Folder_Location用作 Excel 中的命名范围，那么这样写是否正确；

Set olFolder = ThisWorkbook.Sheets("Setup").Range("Folder_Location")

Where

在哪里

Folder_Location = olNs.Folders("Mailbox_name").Folders("Inbox").Folders("XYZ").Folders("2017").Folders("04. April").Folders("Etc")     

This keeps erroring when I attempt to link it to olFolder.

当我尝试将其链接到olFolder.

回答by Keyboard Bandit

I know this is an old question but I had the same problem recently and was able to figure it out after going through what you had done already.

我知道这是一个老问题，但我最近遇到了同样的问题，并且在完成您已经完成的操作后能够弄清楚。

There were only a few changes I needed to make; first I set my selected folder to be my inbox for simplicities sake:

我只需要进行一些更改；首先，为了简单起见，我将所选文件夹设置为我的收件箱：

Set olFolder = olNs.GetDefaultFolder(6) ' 6 == Inbox for some reason

Then, I changed the headings you made just a bit for my readability (not a functional change):

然后，我更改了您为我的可读性所做的标题（不是功能更改）：

ThisWorkbook.Sheets("Data").Range("A1:D1") = Array("Sender Email Address:", "Subject:", "To:", "Size:")

Lastly to get the functionality you were looking for, a small change needed to be made to your indicies in your "Cells" parameter within your for loop:

最后，为了获得您正在寻找的功能，需要对您的 for 循环中的“Cells”参数中的索引进行小的更改：

For iRow = 1 To olFolder.Items.Count
    ThisWorkbook.Sheets("Test").Cells(iRow + 1, 1) = olFolder.Items.Item(iRow).SenderEmailAddress
    ThisWorkbook.Sheets("Test").Cells(iRow + 1, 2) = olFolder.Items.Item(iRow).Subject
    ThisWorkbook.Sheets("Test").Cells(iRow + 1, 3) = olFolder.Items.Item(iRow).To
    ThisWorkbook.Sheets("Test").Cells(iRow + 1, 4) = olFolder.Items.Item(iRow).Size

Next iRow

下一个 iRow

That "+1" in there makes it so we don't overwrite our headers. So the final version looks like this:

那里的“+1”使得我们不会覆盖我们的标题。所以最终版本是这样的：

Sub FetchEmailData()

Dim appOutlook As Object
Dim olNs As Object
Dim olFolder As Object
Dim olItem As Object
Dim iRow As Integer

' Get/create Outlook Application
On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
If appOutlook Is Nothing Then
    Set appOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0

Set olNs = appOutlook.GetNamespace("MAPI")
Set olFolder = olNs.GetDefaultFolder(6) ' 6 == Inbox for some reason

' Clear
ThisWorkbook.Sheets("Test").Cells.Delete

' Build headings:
ThisWorkbook.Sheets("Test").Range("A1:D1") = Array("Sender Email Address:", "Subject:", "To:", "Size:")

For iRow = 1 To olFolder.Items.Count
    ThisWorkbook.Sheets("Test").Cells(iRow + 1, 1) = olFolder.Items.Item(iRow).SenderEmailAddress
    ThisWorkbook.Sheets("Test").Cells(iRow + 1, 2) = olFolder.Items.Item(iRow).Subject
    ThisWorkbook.Sheets("Test").Cells(iRow + 1, 3) = olFolder.Items.Item(iRow).To
    ThisWorkbook.Sheets("Test").Cells(iRow + 1, 4) = olFolder.Items.Item(iRow).Size
Next iRow

End Sub