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

最后发布: 2017-04-27 06:17:14


问题

使用应根据变量(Excel中的值/命名范围)进入Outlook中指定文件夹的Excel宏,并从指定文件夹中的电子邮件中提取数据(收件人:字段,主题,..等)。

代码工作得很好和花花公子,除了我无法提取除了电子邮件的“主题”和“大小”数据之外的任何部分。 如果我尝试使用与“主题”或“大小”编码相同的方法拉入“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

任何帮助将不胜感激,或者如果有人能指出我正确的方向修改代码,以便能够提取其他电子邮件字段,如FromTo字段。

另外,如果我的Set olFolder值是excel中的命名范围,它随日期( =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时,这会对我造成错误

再次谢谢你

excel vba email outlook extract
回答

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

我需要做出一些改变; 首先,我将我选择的文件夹设置为我的收件箱,以简化:

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

然后,为了便于阅读,我改变了你所做的标题(不是功能改变):

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

最后,为了获得您正在寻找的功能,需要在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

下一个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