从Outlook到Excel的自动文本提取

Question

我在这里有点力不从心，肯定是在摸索。

场景：

组织中的每一位新员工每天都会收到共享收件箱中的电子邮件。这是其中一封电子邮件的全文：

The following are the new user details:
Full Name: Martha Washington
Employee ID: 123456
Department: Nursing Education and Research
Division: 17
RC: 730216
Job Title: Clin Nurse PRN Dept
Location: Medical Office Bldg West
Username: 12345678

我需要制作/修改一个脚本，该脚本将只从该电子邮件正文中提取3行，并将它们放入Excel中的列中。我需要获得Username值、Job Title值和Location值，并将它们放在单独的列中。然后，下一封收到的电子邮件需要提取相同的数据，并将其放在Excel中的新行中。

我希望Excel文件看起来像这样：

位置妻子

用户名	职务
gwashing	密歇根州总统
mwashing	纽约

Outlook对象模型提供了应用程序类的NewMailEx事件，该事件在新邮件到达收件箱时以及客户端规则处理发生之前触发。使用EntryIDCollection字符串表示的条目ID来调用NameSpace.GetItemFromID方法并处理该项。此事件为Microsoft Outlook处理的每个收到的项目触发一次。项目可以是几种不同项目类型中的一种，例如MailItem、MeetingItem或SharingItem。因此，在NewMailEx事件中，您可以获得传入电子邮件的一个实例，在该实例中您可以从邮件正文中提取所有必需的信息。

Outlook对象模型提供了三种处理项目主体的主要方法：

1. 身体
2. HTMLBody
3. Word编辑器。Inspector类的WordEditor属性返回表示消息正文的Word文档的实例

有关详细信息，请参阅第17章：使用项目主体。

我的outlook应用程序中也有类似的东西。

这就是Outlook VBA：

Sub Provtagning(msg As Outlook.MailItem)
Dim RE As Object
Dim objFolder As Outlook.MAPIFolder
Dim xExcelFile As String
Dim xExcelApp As Excel.Application
Dim wb As Excel.Workbook

xExcelFile = "Path to file"
' wait for file to be closed (if multiple mails arrive at the same time)
While IsWorkBookOpen(xExcelFile)
WasteTime (1)
Wend
DoEvents


Set xExcelApp = CreateObject("Excel.Application")
Set wb = xExcelApp.Workbooks.Open(xExcelFile)

Set RE = CreateObject("vbscript.regexp")
lrow = wb.Sheets("Sheet1").Cells(wb.Sheets("Sheet1").rows.Count, "A").End(xlUp).Row + 1

RE.Pattern = "Username:s(d+)"
Set allMatches = RE.Execute(msg.Body)
username = allMatches.Item(0).SubMatches.Item(0)

RE.Pattern = "Job Title:s([a-zA-Z ]+)"
Set allMatches = RE.Execute(msg.Body)
title = allMatches.Item(0).SubMatches.Item(0)
RE.Pattern = "Location:s([a-zA-Z ]+)"
Set allMatches = RE.Execute(msg.Body)
location = allMatches.Item(0).SubMatches.Item(0)    
wb.Sheets("Sheet1").Range("A" & lrow).Value = username
wb.Sheets("Sheet1").Range("B" & lrow).Value = title
wb.Sheets("Sheet1").Range("C" & lrow).Value = location
wb.Save
wb.Close
End Sub
Sub WasteTime(Finish As Long)

Dim NowTick As Long
Dim EndTick As Long

EndTick = GetTickCount + (Finish * 1000)

Do

NowTick = GetTickCount
DoEvents

Loop Until NowTick >= EndTick

End Sub
Function IsWorkBookOpen(FileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0:    IsWorkBookOpen = False
Case 70:   IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function

如果有不同的地方，您可能需要调整正则表达式模式。

然后只需在Outlook中创建一个规则，即可在来自SomeEmail或其他触发器的每封电子邮件上运行此脚本。