使用Excel VBA从Outlook文件夹中提取电子邮件数据

Question

使用Excel基于变量（Excel中的值/命名范围）进入Outlook中指定文件夹的宏，并从指定文件夹中的电子邮件中提取数据（To ：字段，主题，..等）。

除了电子邮件的“主题”和“大小”数据之外，除了无法提取任何内容的部分外，代码的工作原理都很好。例如，如果我尝试使用与“主题”或“大小”编码相同的方法提取“To”数据，则会出现“运行时错误'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 

任何帮助将不胜感激，或者如果任何人都可以在正确的方向指向我修改代码，以便能够提取其他电子邮件字段，如From和To字段。

另外，如果我的Set olFolder值是在ex中的命名范围cel会随着日期而动态变化（=Today()），并使用Folder_Location作为Excel中的命名范围，是否可以正确写入;

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

凡

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

在Excel - >这使示数上我，当我试图再次将其olFolder

，谢谢

Answer 1

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

我只需要做一些改变;首先，我把我的选择的文件夹，给我的纯朴的缘故收件箱：

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

然后，我改变了你做只是有点为我的可读性标题（不是功能性改变）：

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

最后让你要找的功能，一个小的变化需要你indicies来进行你的“单元格格式”参数中的for循环：

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 

下一页iRow

那里的“+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