VBA实现Outlook指定日期邮件HTML表导入Excel及报错解决

• 语法错误：日期判断行末尾多写了一个右括号，直接触发VBA编译失败，代码无法启动。
• 未定义变量：循环中声明的邮件对象变量为oMail，但判断语句误用了从未声明的OutlookMail作为对象名，即使去掉多余括号，也会触发“变量未定义”的编译错误。
• 类型不匹配风险：若Email_ReciptDate单元格以文本格式存储日期内容，直接取值和Outlook带时分秒的ReceivedTime属性做比较，会触发运行时类型错误。
• 遍历逻辑漏洞：原代码直接遍历文件夹所有项目时，会遇到会议邀请、任务、系统通知等非邮件类对象，直接读取这类对象的HTMLBody属性，会触发类型转换异常。

Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oItem As Object ' 用通用对象遍历文件夹项目，规避非邮件对象的类型报错
Dim oMail As Outlook.MailItem
Dim HTMLdoc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection
Dim table As MSHTML.HTMLTable
Dim x As Long, y As Long
Dim destCell As Range
Dim filterDate As Date

' 提前将筛选日期转成Date类型，从根源规避单元格格式不兼容问题
filterDate = CDate(ActiveSheet.Range("Email_ReciptDate").Value)

With ActiveSheet
    ' 初始化写入起点：已有数据时从最后一行的下一行开始写入，空表从A1开始
    If .Cells(.Rows.Count, "A").End(xlUp).Value <> "" Then
        Set destCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
    Else
        Set destCell = .Cells(1, 1)
    End If
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").PickFolder

If Not oMapi Is Nothing Then
    ' 遍历选定文件夹下的所有项目
    For Each oItem In oMapi.Items
        ' 仅处理普通邮件类型，跳过其他非邮件项目
        If TypeName(oItem) = "MailItem" Then
            Set oMail = oItem
            ' 修正变量名，用预转换的日期值做筛选比较
            If oMail.ReceivedTime >= filterDate Then
                ' 解析邮件HTML内容，提取表格元素
                Set HTMLdoc = New MSHTML.HTMLDocument
                HTMLdoc.Body.innerHTML = oMail.HTMLBody
                Set tables = HTMLdoc.getElementsByTagName("table")
        
                ' 逐表格写入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
            End If
        End If
    Next
        
    MsgBox "导入完成"
    
End If

' 释放系统对象内存
Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set oItem = Nothing
Set HTMLdoc = Nothing
Set tables = Nothing

可选调整：如果希望仅按日期筛选、忽略邮件的接收时分秒精度，可以将日期赋值行修改为filterDate = DateValue(CDate(ActiveSheet.Range("Email_ReciptDate").Value))，实现“指定日期当天0点起收到的邮件全部导入”的效果。

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