如何使用VBA根据邮件主题提取Outlook电子邮件中的数据

核心修改点 #

• 移除了子文件夹读取逻辑，直接遍历「收件箱」下的所有邮件
• 新增主题匹配配置：可自定义筛选关键词，支持模糊/精确两种匹配模式
• 清理了原代码中冗余的新建邮件对象代码，提升运行效率

可自定义配置项 #

你只需要修改代码开头的两个常量即可适配你的需求：

• TARGET_SUBJECT_KEYWORD：填入你要筛选的邮件主题内容
• IS_FUZZY_MATCH：True为模糊匹配（主题包含关键词即命中），False为精确匹配（主题完全一致才命中）

完整代码 #

Option Explicit

' ************************ 自定义配置区域 开始 ************************
' 要匹配的邮件主题关键词
Const TARGET_SUBJECT_KEYWORD As String = "你要筛选的主题内容"
' 匹配模式：True=模糊匹配（主题包含关键词即可），False=精确匹配（主题完全一致）
Const IS_FUZZY_MATCH As Boolean = True
' ************************ 自定义配置区域 结束 ************************

Sub ImportTable()
    Cells.Clear
    Dim OLApp As Outlook.Application
    Set OLApp = New Outlook.Application
    
    Dim ONS As Outlook.Namespace
    Set ONS = OLApp.GetNamespace("MAPI")
    ' 直接定位到收件箱，不再读取子文件夹
    Dim myFolder As Outlook.Folder
    Set myFolder = ONS.Folders("emailaddress").Folders("Inbox")
    
    Dim OLMAIL As Outlook.MailItem
    Dim subjectMatch As Boolean
    
    For Each OLMAIL In myFolder.Items
        ' 先判断主题是否匹配
        subjectMatch = False
        If IS_FUZZY_MATCH Then
            If InStr(1, OLMAIL.Subject, TARGET_SUBJECT_KEYWORD, vbTextCompare) > 0 Then
                subjectMatch = True
            End If
        Else
            If StrComp(OLMAIL.Subject, TARGET_SUBJECT_KEYWORD, vbTextCompare) = 0 Then
                subjectMatch = True
            End If
        End If
        
        ' 主题不匹配就跳过当前邮件
        If Not subjectMatch Then GoTo NextMail
        
        Dim oHTML As MSHTML.HTMLDocument
        Set oHTML = New MSHTML.HTMLDocument
        Dim oElColl As MSHTML.IHTMLElementCollection
        With oHTML
            .Body.innerHTML = OLMAIL.HTMLBody
            Set oElColl = .getElementsByTagName("table")
        End With
    
        Dim t As Long, r As Long, c As Long
        Dim eRow As Long
    
        For t = 0 To oElColl.Length - 1
            eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            For r = 0 To (oElColl(t).Rows.Length - 1)
                For c = 0 To (oElColl(t).Rows(r).Cells.Length - 1)
                    Range("A" & eRow).Offset(r, c).Value = oElColl(t).Rows(r).Cells(c).innerText
                Next c
            Next r
            eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        Next t
            
        'Cells(eRow, 1) = "Sender's Name:" & " " & OLMAIL.Sender
        'Cells(eRow, 1).Interior.Color = vbRed
        'Cells(eRow, 1).Font.Color = vbWhite
        Cells(eRow, 1) = "Date & Time of Receipt:" & " " & OLMAIL.ReceivedTime
        Cells(eRow, 1).Interior.Color = vbRed
        Cells(eRow, 1).Font.Color = vbWhite
        Cells(eRow, 1).Columns.AutoFit
            
NextMail:
    Next OLMAIL
    
    Range("A1").Select
    
    Set OLApp = Nothing
    Set OLMAIL = Nothing
    Set oHTML = Nothing
    Set oElColl = Nothing
    
    On Error Resume Next
    Range("A1:A" & Worksheets(1).UsedRange.Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
    'ThisWorkbook.VBProject.VBE.MainWindow.Visible = False

End Sub

注意事项 #

• 请将代码中emailaddress替换为你自己的Outlook邮箱账户地址
• 匹配时默认不区分大小写，如果需要区分大小写，可以把vbTextCompare改为vbBinaryCompare
• 运行代码前请确认已经在VBA编辑器的「工具-引用」中勾选了「Microsoft Outlook xx.x Object Library」和「Microsoft HTML Object Library」

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