Outlook指定账户下按发件人分拣邮件的VBA运行报错咨询

你遇到的8004010f未找到对象错误由代码中的多个问题共同导致，逐一修复即可：

• 变量名拼写错误：代码中Set myItem = myItems.FindNext行的myItems未声明定义，你仅在前面用了f.Items获取收件箱条目集合，未将其赋值给myItems变量，运行到这行时会直接抛出对象不存在错误。
• 缺少对象存在性校验：代码未校验目标文件夹zzz是否存在，也未提前判断收件箱中是否有匹配发件人名称的邮件，任意一项不存在都会直接触发报错。
• 账户匹配逻辑不严谨：直接对acc账户对象做字符串对比，部分Outlook版本会出现匹配异常，应该明确取账户的SMTP地址属性做对比。

修复后的完整代码 #

Option Explicit
Sub ResolveName()
    Dim ns As NameSpace
    Set ns = Application.Session
    Dim acc As Account
    Dim f As Folder
    Dim myDestFolder As Folder
    Dim myItems As Items
    Dim myItem As Object
    
    Const TARGET_ACCOUNT As String = "myemail@company.com"
    Const TARGET_FOLDER As String = "zzz"
    Const TARGET_SENDER As String = "SendersName Surname"
 
    For Each acc In ns.Accounts
        ' 明确取SMTP地址匹配账户，避免匹配异常
        If LCase(acc.SmtpAddress) = LCase(TARGET_ACCOUNT) Then
            Set f = acc.DeliveryStore.GetDefaultFolder(olFolderInbox)
            
            ' 校验目标文件夹是否存在
            On Error Resume Next
            Set myDestFolder = f.Folders(TARGET_FOLDER)
            On Error GoTo 0
            If myDestFolder Is Nothing Then
                MsgBox "收件箱下未找到" & TARGET_FOLDER & "文件夹，请先创建", vbCritical
                Exit Sub
            End If
            
            Set myItems = f.Items
            Set myItem = myItems.Find("[SenderName] = '" & TARGET_SENDER & "'")
            While TypeName(myItem) <> "Nothing"
                myItem.Move myDestFolder
                Set myItem = myItems.FindNext
            Wend
            MsgBox "邮件分拣完成", vbInformation
            Exit Sub
        End If
    Next
    MsgBox "未找到指定账户" & TARGET_ACCOUNT, vbCritical
End Sub

使用注意事项 #

1. 替换代码中TARGET_ACCOUNT、TARGET_FOLDER、TARGET_SENDER三个常量的取值为你的实际需求
2. 运行代码前确认目标邮箱的收件箱下已经创建了对应的zzz子文件夹
3. 首次运行建议先选中少量测试邮件验证逻辑，避免误移动重要邮件

内容的提问来源于stack exchange，提问作者Iker Ruiz Gonzalez