统计共享收件箱及子文件夹特定分类邮件数VBA问题求助

需求 #

• 统计共享收件箱及其所有子文件夹中，分配了特定分类的邮件数量
• 同时统计每个文件夹的总邮件数

现有问题 #

代码可编译，但CountCategories()和ProcessCatFolders()子过程存在逻辑错误：

• 旧版CountCategories仅能统计收件箱根目录的分类邮件，无法遍历子文件夹
• 添加递归的ProcessCatFolders()后，代码能运行，但全局变量gCateg的统计结果无法正常显示在新邮件正文中

问题代码 #

Public gCateg As String
Public gFolders As String

Public Sub GetFolderNames()
Dim oSession As Outlook.NameSpace
Dim oFolder As Outlook.MAPIFolder
Dim oNewMail As Outlook.MailItem

Set oSession = Outlook.Application.GetNamespace("MAPI")

On Error Resume Next
Set oFolder = oSession.Folders("SOME_EMAIL@EMAIL.com").Folders("Inbox")

If (oFolder Is Nothing) Then Exit Sub

ProcessFolder oFolder
CountCategories oFolder

Set oNewMail = Application.CreateItem(olMailItem)
oNewMail.Subject = "EMAIL SUBJECT HERE "
oNewMail.Body = gCateg + gFolders
oNewMail.Display

gFolders = ""
gCateg = ""
End Sub


Sub ProcessFolder(CurrentFolder As Outlook.MAPIFolder)

Dim i As Long
Dim oSubFolder As Outlook.MAPIFolder
Dim oFolder As Outlook.MAPIFolder
Dim sFolderPaths As String

For i = CurrentFolder.Folders.Count To 1 Step -1
    Set oFolder = CurrentFolder.Folders(i)

    sFolderPaths = oFolder
    gFolders = gFolders & vbCrLf & sFolderPaths & " " & oFolder.Items.Count
Next

For Each oSubFolder In CurrentFolder.Folders
    If oSubFolder.Name <> "Deleted Items" Then
        ProcessFolder oSubFolder
    End If
Next

End Sub


Sub CountCategories(CurrentFolder As Outlook.MAPIFolder)
Dim oSession As Outlook.NameSpace
Dim oFolder As Outlook.MAPIFolder

Dim iCATEGORYa As Long
Dim iCATEGORYb As Long
Dim iCATEGORYc As Long
Dim iNone As Long

    iCATEGORYa = 0
    iCATEGORYb = 0
    iCATEGORYc = 0
    iNone = 0
    
    Set oSession = Outlook.Application.GetNamespace("MAPI")

    On Error Resume Next
    Set oFolder = oSession.Folders("SOME_EMAIL@EMAIL.com").Folders("Inbox")

    If (oFolder Is Nothing) Then Exit Sub

    ProcessCatFolders oFolder

End Sub
         

Sub ProcessCatFolders(CurrentFolder As Outlook.MAPIFolder)
    Dim olItem As Outlook.MailItem
    Dim oSubFolder As Outlook.MAPIFolder
    Dim oSession As Outlook.NameSpace
    Dim oFolder As Outlook.MAPIFolder
    
    For Each olItem In oFolder.Items
        Select Case olItem.Categories
            Case Is = "CATEGORYa": iCATEGORYa = iCATEGORYa + 1
            Case Is = "CATEGORYb": iCATEGORYb = iCATEGORYb + 1
            Case Is = "CATEGORYc": iCATEGORYc = iCATEGORYc + 1
            Case Else: iNone = iNone + 1
        End Select
        gCateg = "CATEGORYa : " & iCATEGORYa & vbCr & _
          "CATEGORYb : " & iCATEGORYb & vbCr & _
          "CATEGORYc : " & iCATEGORYc & vbCr & _
          "Unflagged: " & iNone & vbCr & _
          "" & vbCr

    Next olItem

    For Each oSubFolder In CurrentFolder.Folders
        If oSubFolder.Name <> "Deleted Items" Then
            ProcessCatFolders oSubFolder
        End If
    Next

End Sub

修复方案及代码 #

关键问题点解析 #

1. 计数变量作用域错误：CountCategories中的iCATEGORYa等是局部变量，递归的ProcessCatFolders无法访问，导致统计无效
2. 文件夹对象引用错误：ProcessCatFolders中误用未赋值的oFolder，应该使用传入的CurrentFolder参数
3. 全局变量赋值逻辑错误：gCateg在邮件遍历循环内反复赋值，会覆盖之前的统计结果，应该在所有统计完成后统一生成文本
4. 文件夹名称获取错误：ProcessFolder中sFolderPaths = oFolder直接赋值对象，应该取文件夹名称oFolder.Name

修复后的完整代码 #

' 全局变量：存储分类统计结果和文件夹统计结果
Public gCateg As String
Public gFolders As String
' 全局计数变量：让递归过程能共享统计值
Public iCATEGORYa As Long, iCATEGORYb As Long, iCATEGORYc As Long, iNone As Long

Public Sub GetFolderNames()
    Dim oSession As Outlook.NameSpace
    Dim oFolder As Outlook.MAPIFolder
    Dim oNewMail As Outlook.MailItem

    Set oSession = Outlook.Application.GetNamespace("MAPI")

    On Error Resume Next
    Set oFolder = oSession.Folders("SOME_EMAIL@EMAIL.com").Folders("Inbox")
    On Error GoTo 0 ' 恢复错误捕获，避免隐藏其他问题

    If oFolder Is Nothing Then
        MsgBox "未找到指定共享收件箱或收件箱文件夹"
        Exit Sub
    End If

    ' 初始化全局变量
    gFolders = ""
    gCateg = ""
    iCATEGORYa = 0: iCATEGORYb = 0: iCATEGORYc = 0: iNone = 0

    ' 执行统计
    ProcessFolder oFolder
    ProcessCatFolders oFolder

    ' 生成分类统计文本（统一在最后生成，避免覆盖）
    gCateg = "=== 分类邮件统计 ===" & vbCrLf & _
             "CATEGORYa : " & iCATEGORYa & vbCrLf & _
             "CATEGORYb : " & iCATEGORYb & vbCrLf & _
             "CATEGORYc : " & iCATEGORYc & vbCrLf & _
             "未分类邮件: " & iNone & vbCrLf & vbCrLf

    ' 生成并显示结果邮件
    Set oNewMail = Application.CreateItem(olMailItem)
    oNewMail.Subject = "共享收件箱邮件统计结果"
    oNewMail.Body = gCateg & "=== 文件夹总邮件数统计 ===" & vbCrLf & gFolders
    oNewMail.Display
End Sub

' 递归统计每个文件夹的总邮件数
Sub ProcessFolder(CurrentFolder As Outlook.MAPIFolder)
    Dim oSubFolder As Outlook.MAPIFolder
    ' 添加当前文件夹的统计
    gFolders = gFolders & CurrentFolder.Name & " : " & CurrentFolder.Items.Count & vbCrLf
    ' 递归处理子文件夹
    For Each oSubFolder In CurrentFolder.Folders
        If oSubFolder.Name <> "Deleted Items" Then
            ProcessFolder oSubFolder
        End If
    Next
End Sub

' 递归统计所有文件夹的分类邮件
Sub ProcessCatFolders(CurrentFolder As Outlook.MAPIFolder)
    Dim olItem As Object ' 用Object兼容非邮件项，避免错误
    Dim oSubFolder As Outlook.MAPIFolder

    ' 遍历当前文件夹的所有项
    For Each olItem In CurrentFolder.Items
        ' 仅处理邮件项
        If TypeName(olItem) = "MailItem" Then
            Select Case olItem.Categories
                Case "CATEGORYa": iCATEGORYa = iCATEGORYa + 1
                Case "CATEGORYb": iCATEGORYb = iCATEGORYb + 1
                Case "CATEGORYc": iCATEGORYc = iCATEGORYc + 1
                Case Else: iNone = iNone + 1
            End Select
        End If
    Next olItem

    ' 递归处理子文件夹
    For Each oSubFolder In CurrentFolder.Folders
        If oSubFolder.Name <> "Deleted Items" Then
            ProcessCatFolders oSubFolder
        End If
    Next
End Sub

修复说明 #

• 将计数变量改为全局，确保递归过程能累计统计值
• 修正ProcessCatFolders中的文件夹引用，使用传入的CurrentFolder
• 统一在所有统计完成后生成gCateg文本，避免循环内覆盖
• 优化ProcessFolder逻辑，直接统计当前文件夹再递归子文件夹，同时修复文件夹名称获取方式
• 添加错误捕获恢复，避免隐藏其他问题
• 用Object遍历文件夹项，避免非邮件项导致的运行错误

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