使用Excel VBA从Outlook提取发件人及正文时遇应用定义错误

错误原因分析 #

• 直接将日期类型的ReceivedTime与字符串"6/6/2025"比较，类型不匹配可能引发后续对象访问异常。
• 部分特殊邮件（如共享邮箱邮件、代理发送邮件）无法直接通过SenderName获取发件人信息。
• 极少数情况下邮件正文损坏或对象未完全加载，导致Body访问失败。

修改后的完整代码 #

Sub ExtractMail()
    Dim OutApp As New Outlook.Application
    Dim OutNamespace As Namespace
    Dim OutFolder As Folder
    Dim OutItem As Object
    Dim OutMail As MailItem
    Dim ws As Worksheet
    Dim maxLength As Long
    Dim i As Long
    Dim bodyPart As String
    Dim targetDate As Date ' 定义目标日期变量
    
    Set ws = ThisWorkbook.Sheets("PullOpenPackagesEmail")
    
    maxLength = 3000
    targetDate = DateSerial(2025, 6, 6) ' 用日期函数生成标准日期类型
    
    Set OutNamespace = OutApp.GetNamespace("MAPI")
    ' 先检查目标文件夹是否存在，避免找不到文件夹报错
    On Error Resume Next
    Set OutFolder = OutNamespace.GetDefaultFolder(olFolderInbox).Folders("Re-open Packages")
    On Error GoTo 0
    If OutFolder Is Nothing Then
        MsgBox "找不到指定文件夹：Re-open Packages", vbExclamation
        Exit Sub
    End If
    
    r = 1
    ' 提前过滤符合时间条件的邮件，提升处理效率
    Dim filteredItems As Items
    Set filteredItems = OutFolder.Items.Restrict("[ReceivedTime] > '" & Format(targetDate, "ddddd h:nn AMPM") & "'")
    filteredItems.Sort "[ReceivedTime]", olDescending ' 按接收时间倒序排序
    
    For Each OutItem In filteredItems
        If TypeName(OutItem) = "MailItem" Then
            Set OutMail = OutItem
            r = r + 1
            ws.Range("A" & r).Value = OutMail.ReceivedTime
            
            ' 安全获取发件人名称，异常时降级处理
            On Error Resume Next
            ws.Range("B" & r).Value = OutMail.SenderName
            If Err.Number <> 0 Then
                ws.Range("B" & r).Value = OutMail.SentOnBehalfOfName
                If ws.Range("B" & r).Value = "" Then ws.Range("B" & r).Value = "未知发件人"
            End If
            On Error GoTo 0
            
            ws.Range("C" & r).Value = OutMail.Subject
            
            ' 安全获取邮件正文，异常时提示
            On Error Resume Next
            bodyPart = OutMail.Body
            If Err.Number <> 0 Then
                bodyPart = "无法获取邮件正文"
            End If
            On Error GoTo 0
            
            ' 拆分过长的正文内容
            If Len(bodyPart) > maxLength Then
                For i = 1 To Len(bodyPart) Step maxLength
                    ws.Range("D" & r).Value = Mid(bodyPart, i, maxLength)
                    r = r + 1
                Next i
            Else
                ws.Range("D" & r).Value = bodyPart
            End If
        End If
    Next OutItem
End Sub

关键修改点说明 #

1. 日期处理优化：用DateSerial生成标准日期类型，并用Restrict方法提前筛选邮件，既避免类型比较错误，又减少循环次数提升效率。
2. 错误捕获：对SenderName和Body的访问添加错误捕获，出现异常时自动用代理发件人名称或提示文本替代，避免代码中断。
3. 文件夹校验：先检查目标文件夹是否存在，提前终止并提示，避免后续无意义的执行。
4. 邮件排序：对过滤后的邮件按接收时间倒序排序，确保处理顺序符合预期。

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