共享邮箱递归文件夹搜索的Excel VBA实现求助

问题分析 #

你当前的代码已能正确获取共享收件箱根目录，但缺少递归遍历多层子文件夹的逻辑，且存在未定义变量、未过滤非邮件项等问题，导致无法覆盖所有嵌套文件夹。

修正后的完整代码 #

Option Explicit ' 强制变量声明，避免未定义变量错误

Sub GetFromOutlook()
    Dim OutlookApp As Outlook.Application
    Dim OutlookNamespace As Outlook.Namespace
    Dim mFolder As Outlook.MAPIFolder
    Dim objOwner As Outlook.Recipient
    Dim rowIndex As Long ' 用Long避免行数过多时Integer溢出
    
    ' 初始化Outlook对象
    Set OutlookApp = New Outlook.Application
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    
    ' 获取共享收件箱
    Set objOwner = OutlookNamespace.CreateRecipient("name@company.com")
    objOwner.Resolve
    If objOwner.Resolved Then
        Set mFolder = OutlookNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox)
    Else
        MsgBox "无法解析共享邮箱收件人，请检查邮箱地址", vbCritical
        Exit Sub
    End If
    
    ' 初始化表格（清空旧数据并添加表头）
    Sheet2.Cells.Clear
    Sheet2.Range("A1:F1").Value = Array("序号", "接收时间", "发件人", "收件人", "主题", "邮件内容")
    rowIndex = 2 ' 从第二行开始写入数据
    
    ' 递归处理所有文件夹及子文件夹
    Call ProcessFolder(mFolder, rowIndex)
    
    ' 释放对象
    Set mFolder = Nothing
    Set objOwner = Nothing
    Set OutlookNamespace = Nothing
    Set OutlookApp = Nothing
    
    MsgBox "邮件抓取完成，共获取" & rowIndex - 2 & "封邮件", vbInformation
End Sub

' 递归处理文件夹的核心函数
Sub ProcessFolder(ByVal olFolder As Outlook.MAPIFolder, ByRef rowIndex As Long)
    Dim OutlookMail As Outlook.MailItem
    Dim subFolder As Outlook.MAPIFolder
    
    ' 处理当前文件夹内的所有邮件
    For Each OutlookMail In olFolder.Items
        ' 仅处理邮件类型（过滤日历、任务等非邮件项）
        If TypeName(OutlookMail) = "MailItem" Then
            Sheet2.Range("A" & rowIndex).Value = rowIndex - 1
            Sheet2.Range("B" & rowIndex).Value = OutlookMail.ReceivedTime
            Sheet2.Range("C" & rowIndex).Value = OutlookMail.SenderName
            Sheet2.Range("D" & rowIndex).Value = OutlookMail.To
            Sheet2.Range("E" & rowIndex).Value = OutlookMail.Subject
            Sheet2.Range("F" & rowIndex).Value = OutlookMail.Body
            
            rowIndex = rowIndex + 1
        End If
    Next OutlookMail
    
    ' 递归遍历当前文件夹下的所有子文件夹
    For Each subFolder In olFolder.Folders
        Call ProcessFolder(subFolder, rowIndex)
    Next subFolder
End Sub

关键改进点 #

• 递归遍历逻辑：通过ProcessFolder函数自动处理所有层级的子文件夹，不管嵌套多少层都能覆盖。
• 变量安全：用Long类型存储行号，避免Excel行数超过Integer上限（32767）导致溢出；添加Option Explicit强制变量声明，排查未定义变量错误。
• 数据过滤：通过TypeName判断仅处理邮件项，避免非邮件对象（如会议邀请）引发的运行时错误。
• 表格初始化：清空旧数据并添加表头，让输出结果更规范。

共享邮箱设置截图 #

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