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

Question

每次在调度系统中预订房间时，我都会收到一封自动电子邮件消息（在 Outlook 中），但随后必须检查并在另一个系统中反映该预订（这需要检查每个预订以获取特定信息并在收件箱中搜索）。我正在尝试确定是否有办法从消息部分中提取信息（我发现一些代码可以提取收到的日期、主题行以及阅读状态，但无法确定如何提取消息正文信息我需要）

我正在运行的代码由Jie Jenn提供：

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

使用上面的代码，我可以读取主题行、创建/接收日期以及是否已阅读。此外，我正在尝试查看是否可以在消息本身中获取一些唯一的字符串数据。我收到的邮件格式如下：

消息 ID：示例信息

用户：测试

内容1：测试

内容2：测试

内容3：测试

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

-新房间申请通知

赞助商：My_example@Test.com

活动类型：会议

事件标题：测试

预订日期：2015-12-02

房间：150

从：13:00 至：14:00

信息会因每个请求而异，但我想知道是否有人知道如何捕获将通过的唯一字符串，以便我可以保存比当前手动输入快得多的请求日志并仔细检查？

Answer 1

按照后续要求，以下代码将消息正文拆分为单独的信息行。一些注意事项：我完全从您的帖子中复制了您的消息，然后搜索“新房间请求通知”。不用说，这个字符串应该总是开始你需要的信息块。如果它发生变化，那么我们必须考虑可能通过的消息类型。此外，您可能必须测试您的消息正文如何分解各个行。当我将您的消息复制并粘贴到 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 中编写代码来查找新邮件到达，然后从那里测试它是否符合您的标准，如果符合，它可以写入 Excel。这是一个帮助您入门的链接。回复以获取更多帮助。

Using VBA to read new Outlook Email?