将Outlook电子邮件信息导出到Excel工作簿

每次在预定系统中预留房间时，我都会收到一封自动发送的电子邮件（在Outlook中），但必须在另一个系统（需要检查每个预留以查找特定信息并通过收件箱进行search）中进行查看。 我试图确定是否有一种方法来从消息部分拉（我已经find了一些代码拉的收到的date，主题行以及读取状态，但不能确定如何拉消息正文信息我需要）

我正在运行的代码是由詹杰提供的：

Sub ListOutlookEmailInfoinExcel() Dim olNS As Outlook.NameSpace Dim olTaskFolder As Outlook.MAPIFolder Dim olTask As Outlook.TaskItem Dim olItems As Outlook.Items Dim xlApp As Excel.Application Dim xlWB As Excel.Workbook Dim x As Long Dim arrHeaders As Variant Set olNS = GetNamespace("MAPI") Set olTaskFolder = olNS.GetDefaultFolder(olFolderInbox) Set olItems = olTaskFolder.Items Set xlApp = CreateObject("Excel.Application") xlApp.Visible = True Set xlWB = xlApp.Workbooks.Add On Error Resume Next x = 2 arrHeaders = Array("Date Created", "Date Recieved", "Subject", "Unread?") xlWB.Worksheets(1).Range("A1").Resize(1, UBound(arrHeaders)).Value = "" Do With xlWB.Worksheets(1) If Not (olItems(x).Subjects = "" And olItems(x).CreationTime = "") Then .Range("A1").Resize(1, UBound(arrHeaders) + 1) = arrHeaders .Cells(x, 1).Value = olItems(x).CreationTime .Cells(x, 2).Value = olItems(x).ReceivedTime .Cells(x, 3).Value = olItems(x).Subject .Cells(x, 4).Value = olItems(x).UnRead x = x + 1 End If End With Loop Until x >= olItems.Count + 1 Set olNS = Nothing Set olTaskFolder = Nothing Set olItems = Nothing Set xlApp = Nothing Set xlWB = Nothing End Sub 

使用上面的代码，我可以读出主题行，创build/接收的date以及是否已经读取。 我试图看看，如果我可以，另外，在消息本身得到一些独特的string数据。 我收到的电子邮件格式如下：

消息ID：示例信息

用户：testing

内容1：testing

内容2：testing

Content3：testing

如果您错误地收到此消息，请提交服务请求。

新房请求的通知

赞助商：[e-mail]

事件types：会议

活动标题：testing

预订date：2015-12-02

房间：150

从：13：00 至14:00

信息会随着每个请求而变化，但是我想知道是否有人想知道如何捕获将要经过的唯一string，这样我就可以保存比当前手动input快得多的请求日志，检查？

Answer 1

按照后续要求，下面的代码将消息正文拆分为单独的信息行。 几个笔记：我完全从您的post中复制您的消息，然后search“新房申请通知”。 不用说，这个string应该总是启动你需要的信息块。 如果它变化，那么我们必须考虑可能通过的消息的types。 此外，你可能不得不testing你的消息体如何分解个别行。 当我复制并将邮件粘贴到Excel中时，每个换行符都是2个换行符（VBA中的Chr（10））。 在某些情况下，它可能只有一个换行符。 或者它可以是回车（Chr（13）），或甚至两者。

别着急，看下面的代码，让我们知道问题。

 Sub SplitBody() Dim sBody As String Dim sBodyLines() As String sBody = Range("A1").Value sBodyLines() = Split(Mid(sBody, InStr(sBody, "Notice of NEW Room Request"), Len(sBody)), Chr(10) & Chr(10)) For i = LBound(sBodyLines) To UBound(sBodyLines) MsgBox (sBodyLines(i)) Next i End Sub 

Answer 2

以下是连接到Outlook会话的示例，导航到默认收件箱，然后循环查看项目并将未读邮件添加到电子表格。 查看是否可以根据需要修改代码，如果需要特定帮助，请回复。

 Sub LinkToOutlook() Dim olApp As Object Dim olNS As Object Dim olFolderInbox As Object Dim rOutput As Range Set olApp = CreateObject("Outlook.Application") Set olNS = olApp.getNamespace("MAPI") Set olFolderInbox = olNS.GetDefaultFolder(6) 'Gets the default inbox folder Set rOutput = Sheet1.Range("A1") For Each itm In olFolderInbox.items If itm.unread = True Then 'check if it has already been read rOutput.Value = itm.body Set rOutput = rOutput.Offset(1) End If Next itm End Sub 

或者，您可以直接在Outlook中编写代码来查找新的邮件到达，然后可以testing它是否符合条件，如果符合，则可以写入Excel。 这是一个让你开始的链接。 发回来增加帮助。

使用VBA读取新的Outlook电子邮件？