如何从含指定关键词的Outlook邮件中提取发件人及邮件正文至Excel？

嘿，你已经搞定了邮件筛选的核心步骤，接下来获取发件人信息、提取正文关键词并写入Excel其实思路很清晰，我结合Office VBA的场景给你具体方案——毕竟咱们用的都是微软自家工具，对象模型适配性拉满：

Outlook的MailItem对象自带直接获取发件人信息的属性，不用绕弯路：

• 要用户名的话，用MailItem.SenderName，直接返回发件人的显示名称
• 要邮箱地址的话，用MailItem.SenderEmailAddress，返回完整的邮箱字符串

遍历邮件时的代码片段示例：

Dim olMail As Outlook.MailItem
' 假设你已经通过筛选得到了olMail对象
Dim senderName As String
Dim senderEmail As String
senderName = olMail.SenderName
senderEmail = olMail.SenderEmailAddress

如果是简单的关键词匹配（比如找"故障"、"申请"这类词），用VBA的InStr函数就能快速判断；如果需要批量匹配多个关键词，或者更复杂的模式，用正则表达式更高效。

1. 简单关键词检查 #

Dim bodyText As String
bodyText = olMail.Body ' 若需处理HTML格式正文，改用olMail.HTMLBody
Dim targetKeyword As String
targetKeyword = "故障"
If InStr(bodyText, targetKeyword) > 0 Then
    ' 找到关键词，记录下来
    Debug.Print "正文包含关键词：" & targetKeyword
End If

2. 正则批量匹配多个关键词 #

Dim regExp As Object
Set regExp = CreateObject("VBScript.RegExp")
regExp.Pattern = "故障|申请|报错" ' 用|分隔多个目标关键词
regExp.Global = True ' 匹配所有出现的关键词
Dim matches As Object
Set matches = regExp.Execute(bodyText)
If matches.Count > 0 Then
    Dim match As Object
    For Each match In matches
        Debug.Print "找到关键词：" & match.Value
    Next
End If

把收集到的邮件信息（标题、发件人、关键词）写入Excel，直接用VBA操作Excel对象模型即可：

Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Dim nextRow As Integer

' 启动Excel（后台运行可设置xlApp.Visible = False）
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Open("C:\你的表格路径\上报表格.xlsx") ' 替换为你的Excel路径
Set xlWS = xlWB.Sheets("Sheet1") ' 替换为目标工作表名称

' 定位下一个空行
nextRow = xlWS.Cells(xlWS.Rows.Count, "A").End(-4162).Row + 1 ' -4162对应xlUp常量

' 写入数据
xlWS.Cells(nextRow, "A").Value = olMail.Subject ' 邮件标题
xlWS.Cells(nextRow, "B").Value = senderName ' 发件人用户名
xlWS.Cells(nextRow, "C").Value = senderEmail ' 发件人邮箱
xlWS.Cells(nextRow, "D").Value = "提取到的关键词内容" ' 替换为实际提取的关键词

' 保存并关闭Excel
xlWB.Save
xlWB.Close
xlApp.Quit
Set xlWS = Nothing
Set xlWB = Nothing
Set xlApp = Nothing

把上面的步骤串起来，就是一个完整的遍历-提取-写入流程：

Sub ScanOutlookAndReportToExcel()
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olItems As Outlook.Items
    Dim olMail As Outlook.MailItem
    Dim filter As String
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlWS As Object
    Dim nextRow As Integer
    Dim bodyText As String
    Dim regExp As Object
    Dim matches As Object
    Dim match As Object
    Dim keywordStr As String
    Dim senderName As String
    Dim senderEmail As String
    
    ' 初始化Outlook对象
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.GetDefaultFolder(olFolderInbox) ' 指向收件箱
    
    ' 设置筛选条件：标题包含"Office"
    filter = "@SQL=""urn:schemas:httpmail:subject"" LIKE '%Office%'"
    Set olItems = olFolder.Items.Restrict(filter)
    
    ' 初始化Excel对象
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True ' 调试时显示Excel窗口，发布可改为False
    Set xlWB = xlApp.Workbooks.Open("C:\你的表格路径\上报表格.xlsx")
    Set xlWS = xlWB.Sheets("Sheet1")
    
    ' 初始化正则表达式（匹配正文关键词）
    Set regExp = CreateObject("VBScript.RegExp")
    regExp.Pattern = "故障|申请|报错"
    regExp.Global = True
    
    ' 遍历筛选后的邮件
    For Each olMail In olItems
        If olMail.Class = olMail Then ' 确保当前项是邮件
            ' 获取发件人信息
            senderName = olMail.SenderName
            senderEmail = olMail.SenderEmailAddress
            
            ' 提取正文关键词并拼接成字符串
            bodyText = olMail.Body
            keywordStr = ""
            Set matches = regExp.Execute(bodyText)
            If matches.Count > 0 Then
                For Each match In matches
                    keywordStr = keywordStr & match.Value & ";"
                Next
                keywordStr = Left(keywordStr, Len(keywordStr) - 1) ' 移除末尾多余分号
            End If
            
            ' 写入Excel表格
            nextRow = xlWS.Cells(xlWS.Rows.Count, "A").End(-4162).Row + 1
            xlWS.Cells(nextRow, "A").Value = olMail.Subject
            xlWS.Cells(nextRow, "B").Value = senderName
            xlWS.Cells(nextRow, "C").Value = senderEmail
            xlWS.Cells(nextRow, "D").Value = keywordStr
        End If
    Next
    
    ' 清理对象并提示完成
    xlWB.Save
    xlWB.Close
    xlApp.Quit
    Set xlWS = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
    Set olItems = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    Set regExp = Nothing
    
    MsgBox "邮件扫描和上报完成！"
End Sub

注意事项 #

• 运行前确保Outlook已打开，且宏权限设置允许运行脚本
• 替换代码中的Excel文件路径、工作表名称为你自己的配置
• 若需处理HTML格式邮件正文，可将olMail.Body替换为olMail.HTMLBody，正则匹配模式可能需根据HTML结构调整

内容的提问来源于stack exchange，提问作者Sgdva