如何用VBA遍历Outlook中特定主题的所有邮件并提取内容

问题根因 #

原有代码执行逻辑存在两个问题：

• 遍历邮件的循环中，匹配到第一封主题为Volume data的邮件就执行Exit For直接跳出循环，不会继续遍历剩余邮件
• 邮件内容提取逻辑写在循环外，仅能处理单次匹配到的邮件

修复后的完整代码 #

Option Explicit

Sub impOutlookTable()
    Dim wkb As Workbook
    Set wkb = ThisWorkbook
    
    Sheets("Sheet1").Cells.ClearContents
    
    ' 配置目标邮箱地址
    Const strMail As String = "emailaddress"
    
    Dim oApp As Outlook.Application
    Dim oMapi As Outlook.MAPIFolder
    Dim oItem As Object
    Dim x As Long, y As Long
    Dim destCell As Range
    
    ' 初始化写入起始位置
    With ActiveSheet
        Set destCell = .Cells(Rows.Count, "A").End(xlUp)
        ' 如果工作表为空则从A1开始写入
        If destCell.Row = 1 And destCell.Value = "" Then Set destCell = .Range("A1")
    End With
    
    ' 初始化Outlook对象
    On Error Resume Next
    Set oApp = GetObject(, "OUTLOOK.APPLICATION")
    If (oApp Is Nothing) Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
    On Error GoTo 0
    
    ' 定位到目标收件箱
    Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox")
    
    ' 遍历所有收件箱项目
    For Each oItem In oMapi.Items
        ' 仅处理类型为邮件、主题匹配的项目
        If TypeName(oItem) = "MailItem" And oItem.Subject = "Volume data" Then
            Dim HTMLdoc As MSHTML.HTMLDocument
            Dim tables As MSHTML.IHTMLElementCollection
            Dim table As MSHTML.HTMLTable
            
            ' 解析邮件HTML内容
            Set HTMLdoc = New MSHTML.HTMLDocument
            With HTMLdoc
                .Body.innerHTML = oItem.HTMLBody
                Set tables = .getElementsByTagName("table")
            End With
            
            ' 把表格内容写入Excel
            For Each table In tables
                For x = 0 To table.Rows.Length - 1
                    For y = 0 To table.Rows(x).Cells.Length - 1
                        destCell.Offset(x, y).Value = table.Rows(x).Cells(y).innerText
                    Next y
                Next x
                ' 写入完成后偏移目标单元格，避免下一封邮件内容覆盖
                Set destCell = destCell.Offset(x + 1)
            Next
            
            ' 释放当前邮件相关对象
            Set HTMLdoc = Nothing
            Set tables = Nothing
            Set table = Nothing
        End If
    Next oItem
    
    ' 释放所有公共对象
    Set oApp = Nothing
    Set oMapi = Nothing
    Set oItem = Nothing
    
    ' 保存文件
    wkb.SaveAs "C:\Users\Desktop\New_email.xlsm"
End Sub

注意事项 #

运行前请确保VBA编辑器中已经勾选对应引用：

• 工具 -> 引用 -> 勾选 Microsoft Outlook xx.x Object Library（xx.x对应你安装的Outlook版本号）
• 工具 -> 引用 -> 勾选 Microsoft HTML Object Library

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