使用Excel VBA从Outlook文件夹中提取电子邮件数据
使用基于variables(Excel中的值/命名范围)进入Outlook中指定文件夹的Excelmacros,并从指定文件夹(To:field,Subject,..等)中的电子邮件中提取数据。
除了电子邮件的“主题”和“大小”数据之外的任何部分,代码都可以正常工作。 如果我尝试使用与“主题”或“大小”编码相同的方法拉入“收件人”数据,则会出现“运行时错误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
值是Excel中的一个命名范围,它随date( =Today()
)dynamic更改,并且在Excel中使用Folder_Location
作为命名范围,那么写入是否正确;
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
时,这不断对我进行error handling
再次谢谢你
我知道这是一个古老的问题,但最近我也遇到了同样的问题,并且在经历了已经完成的工作之后才能够弄清楚。
我只需要做一些改变; 首先我将我select的文件夹设置为我的收件箱,为了简单起见,
Set olFolder = olNs.GetDefaultFolder(6) ' 6 == Inbox for some reason
然后,我改变了你为了我的可读性而做的标题(不是function上的改变):
ThisWorkbook.Sheets("Data").Range("A1:D1") = Array("Sender Email Address:", "Subject:", "To:", "Size:")
最后,为了获得你正在寻找的function,需要在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