Outlook VBA访问共享收件箱子文件夹报8004010f对象未找到错误

运行抛出-2147221233 (8004010f)对象找不到错误，核心问题有3个：

1. 创建共享邮箱收件人对象后，没有调用Resolve方法完成Exchange地址解析，拿到的共享收件箱根对象本身不完整，后续遍历子文件夹时无法匹配实际路径
2. 变量声明存在类型歧义：原代码中Dim olFolder As Folder没有指定Outlook命名空间，在Excel环境下会默认匹配为文件系统的Folder对象，和Outlook文件夹类型不兼容
3. 直接链式硬编码访问多层文件夹，没有做存在性校验，一旦文件夹名存在肉眼不可见的前后空格、本地化命名偏差，就会直接触发找不到对象的报错

• 所有Outlook相关变量显式指定Outlook.前缀声明，避免和Office其他库的同名对象冲突
• 创建共享邮箱对象后立刻执行Resolve方法，确认地址解析成功后再获取共享默认收件箱
• 逐层校验文件夹存在性，不要直接链式调用Folders访问，方便定位具体哪一层文件夹匹配失败
• 若仍匹配失败，可通过调试打印对应层级下的所有真实文件夹名，核对后替换硬编码名称即可

Sub GetFromOutlook()
    Worksheets("Sheet1").Activate
    Dim OutlookApp As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim OutlookMail As Variant
    Dim i As Integer
    Dim olFolder As Outlook.Folder
    Dim olRecip As Outlook.Recipient
    Dim subFolder As Outlook.Folder

    Set OutlookApp = New Outlook.Application
    Set olNs = OutlookApp.GetNamespace("MAPI")
    
    ' 创建并解析共享邮箱地址
    Set olRecip = olNs.CreateRecipient("SHARED EMAIL ADDRESS") ' 替换为实际共享邮箱地址
    olRecip.Resolve
    If Not olRecip.Resolved Then
        MsgBox "共享邮箱地址解析失败，请检查邮箱地址正确性"
        GoTo Cleanup
    End If
    
    ' 获取共享邮箱收件箱根目录
    Set olFolder = olNs.GetSharedDefaultFolder(olRecip, olFolderInbox)
    
    ' 逐层校验访问子文件夹
    On Error Resume Next
    Set subFolder = olFolder.Folders("MY TEAM'S FOLDER")
    If subFolder Is Nothing Then
        ' 打印当前层级所有文件夹名供核对
        Debug.Print "共享收件箱一级子文件夹列表："
        Dim f As Outlook.Folder
        For Each f In olFolder.Folders
            Debug.Print f.Name
        Next
        MsgBox "找不到【MY TEAM'S FOLDER】，请在VBA立即窗口核对实际文件夹名"
        GoTo Cleanup
    End If
    Set olFolder = subFolder
    
    Set subFolder = olFolder.Folders("THE FOLDER I WANT")
    If subFolder Is Nothing Then
        Debug.Print "MY TEAM'S FOLDER下子文件夹列表："
        Dim f2 As Outlook.Folder
        For Each f2 In olFolder.Folders
            Debug.Print f2.Name
        Next
        MsgBox "找不到目标文件夹，请在VBA立即窗口核对实际文件夹名"
        GoTo Cleanup
    End If
    Set olFolder = subFolder
    On Error GoTo 0

    ' 遍历邮件写入表格
    i = 1
    For Each OutlookMail In olFolder.Items
        ' 跳过会议邀请、送达回执等非邮件项
        If TypeName(OutlookMail) = "MailItem" Then
            Cells(i + 1, 1) = OutlookMail.Subject
            Cells(i + 1, 2) = OutlookMail.ReceivedTime
            i = i + 1
        End If
    Next OutlookMail

Cleanup:
    ' 释放对象
    Set subFolder = Nothing
    Set olRecip = Nothing
    Set olNs = Nothing
    Set OutlookApp = Nothing
End Sub

如果运行时弹出找不到文件夹的提示，按Alt+F11打开VBA编辑器，按Ctrl+G调出立即窗口，就能看到对应层级下所有真实存在的文件夹名称，复制打印出的准确名称替换代码里硬编码的文件夹名即可。
注意：需确认当前账号对目标共享邮箱、对应子文件夹拥有至少读取权限，权限不足也会触发同类对象找不到错误。

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