VBA操作Outlook获取邮件并导出至Excel时遇‘对象未定义’错误求助

需求与问题 #

• 需求：通过VBA从Outlook中获取当日收到、指定主题的邮件，将邮件内的表格内容复制至当前Excel工作表。
• 问题：代码执行时在Application.ThisWorkbook.Worksheets("Sheet1").Range("B9").Value = oItem.HTMLBody行触发**“对象未定义”**错误，尝试将oMail声明为Object类型后问题依旧。

原代码 #

Sub Mail3()

Dim Folder As Outlook.MAPIFolder
Dim sFolders As Outlook.MAPIFolder
Dim MailBoxName As String, Pst_Folder_Name  As String
Dim oMail As Object
Dim y As Long, x As Long
Dim olInsp As Outlook.Inspector
Dim wdDoc As Word.Document
Dim tb As Word.Table
Dim Myemail As String
Dim Atmt As Attachment
Dim irow As Integer
Dim oItem As Outlook.MailItem
Dim ns As Namespace
irow = 1
'set email date
Set ns = GetNamespace("MAPI")

Myemail = "abcd"
'Mailbox or PST Main Folder Name to set the name of the inbox - I have several mailboxes, needed to specify
MailBoxName = "myinbox"

'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
Pst_Folder_Name = "Inbox" 'Sample "Inbox" or "Sent Items"

'To direct to a Folder at a high level
Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)

'copying the email contents into the refresh file
For Each oMail In Folder.Items
    If oMail.Class = 43 Then
        Set oMail = oItem
        If oMail.Subject = Myemail And (Now() - oMail.ReceivedTime) < 1 Then
            'oMail.SentOn = DateSerial(Year(Now), Month(Now), Day(Now)) Then
            Application.ThisWorkbook.Worksheets("Sheet1").Range("B9").Value = oItem.HTMLBody
        End If
    End If
Next oMail

End Sub

错误原因与修正方案 #

核心错误点 #

1. oItem未初始化：代码中仅声明了oItem但从未赋值，反而错误执行Set oMail = oItem（逻辑完全颠倒，应为Set oItem = oMail），导致oItem始终为Nothing，调用其HTMLBody属性必然报错。
2. 日期判断不精准：(Now() - oMail.ReceivedTime) < 1会包含过去24小时内的邮件，无法严格匹配当日收到的邮件。
3. 未实现表格提取逻辑：原代码试图写入邮件的HTML源码，而非提取表格内容，与需求不符。

修正后的完整代码 #

Sub ExtractMailTableToExcel()
    Dim Folder As Outlook.MAPIFolder
    Dim MailBoxName As String, Pst_Folder_Name As String
    Dim oMail As Object
    Dim oItem As Outlook.MailItem
    Dim ns As Outlook.Namespace
    Dim olInsp As Outlook.Inspector
    Dim wdDoc As Word.Document
    Dim tb As Word.Table
    Dim ws As Worksheet
    Dim targetRow As Integer
    
    targetRow = 9 ' 表格从B9开始写入
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set ns = GetNamespace("MAPI")
    
    ' 配置参数
    Const TargetSubject As String = "abcd" ' 指定要匹配的邮件主题
    MailBoxName = "myinbox" ' 目标邮箱名称（需与Outlook中显示一致）
    Pst_Folder_Name = "Inbox" ' 目标文件夹（如收件箱）
    
    ' 获取目标文件夹，添加错误处理避免找不到文件夹崩溃
    On Error Resume Next
    Set Folder = ns.Folders(MailBoxName).Folders(Pst_Folder_Name)
    On Error GoTo 0
    If Folder Is Nothing Then
        MsgBox "未找到指定邮箱或文件夹，请检查名称是否正确", vbExclamation
        Exit Sub
    End If
    
    ' 遍历文件夹内所有项目
    For Each oMail In Folder.Items
        ' 仅处理邮件类型对象
        If oMail.Class = olMail Then
            Set oItem = oMail
            ' 判断是否为当日收到且主题匹配
            If oItem.Subject = TargetSubject And DateValue(oItem.ReceivedTime) = Date Then
                ' 通过WordEditor解析邮件内容（需引用Word对象库）
                Set olInsp = oItem.GetInspector
                Set wdDoc = olInsp.WordEditor
                
                ' 遍历邮件内的所有表格并复制到Excel
                For Each tb In wdDoc.Tables
                    tb.Range.Copy
                    ' 粘贴为值和数字格式，避免格式错乱
                    ws.Range("B" & targetRow).PasteSpecial xlPasteValuesAndNumberFormats
                    ' 更新下一个表格的起始行
                    targetRow = targetRow + tb.Rows.Count
                Next tb
            End If
        End If
    Next oMail
    
    ' 释放对象，避免内存泄漏
    Set tb = Nothing
    Set wdDoc = Nothing
    Set olInsp = Nothing
    Set oItem = Nothing
    Set oMail = Nothing
    Set Folder = Nothing
    Set ns = Nothing
    
    MsgBox "表格提取完成", vbInformation
End Sub

额外注意事项 #

• 需在VBA编辑器中引用Microsoft Outlook xx.x Object Library和Microsoft Word xx.x Object Library（路径：工具 → 引用）。
• 若邮件主题包含特殊字符或仅需匹配部分内容，可将oItem.Subject = TargetSubject改为InStr(oItem.Subject, TargetSubject) > 0。

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