Outlook VBA如何引用指定账户下的文件夹完成发件人邮件数统计

完全可以通过调整原代码的文件夹定位逻辑实现需求，同时修正原代码本身存在的类型不匹配隐患。

原代码问题说明：Set objInbox = Outlook.Application.Session.Accounts.Item("edr.hub@bt.com") 这行存在类型不匹配错误：Session.Accounts.Item 返回的是Outlook账户对象，并非文件夹对象，直接赋值给Outlook.Folder类型变量会触发运行时报错，无法正常跑通统计流程。

核心修改点 #

• 将硬编码的账户A地址替换为账户B对应的实际邮箱地址
• 基于目标账户的关联邮箱存储，逐级定位到存储下名为"Done"的目标文件夹
• 增加目标文件夹存在性校验，避免找不到路径时程序直接崩溃
• 原有的发件人计数、Excel导出逻辑完全保留，无需调整

修改后的完整可运行代码 #

Sub CountDoneFolderEmailsBySender()
    ' 配置项：请替换为账户B的实际邮箱地址
    Const TARGET_ACCOUNT As String = "请替换为账户B的实际邮箱地址"
    Const TARGET_FOLDER_NAME As String = "Done"
    
    Dim objDictionary As Object
    Dim objInbox As Outlook.Folder
    Dim objAccount As Outlook.Account
    Dim objStore As Outlook.Store
    Dim objRootFolder As Outlook.Folder
    Dim objSubFolder As Outlook.Folder
    Dim i As Long
    Dim objMail As Outlook.MailItem
    Dim strSender As String
    Dim objExcelApp As Excel.Application
    Dim objExcelWorkbook As Excel.Workbook
    Dim objExcelWorksheet As Excel.Worksheet
    Dim varSenders As Variant
    Dim varItemCounts As Variant
    Dim nLastRow As Integer
 
    Set objDictionary = CreateObject("Scripting.Dictionary")
    
    ' 逐层定位目标账户的Done文件夹
    Set objAccount = Outlook.Application.Session.Accounts.Item(TARGET_ACCOUNT)
    Set objStore = objAccount.DeliverStore
    Set objRootFolder = objStore.GetRootFolder()
    
    ' 遍历根目录子文件夹，匹配Done文件夹
    Set objInbox = Nothing
    For Each objSubFolder In objRootFolder.Folders
        If objSubFolder.Name = TARGET_FOLDER_NAME Then
            Set objInbox = objSubFolder
            Exit For
        End If
    Next
    
    ' 校验文件夹是否存在
    If objInbox Is Nothing Then
        MsgBox "未在账户" & TARGET_ACCOUNT & "的根目录下找到名为" & TARGET_FOLDER_NAME & "的文件夹", vbExclamation
        Exit Sub
    End If
    
    ' 统计发件人邮件数量
    For i = objInbox.Items.Count To 1 Step -1
        If objInbox.Items(i).Class = olMail Then
           Set objMail = objInbox.Items(i)
           strSender = objMail.SenderEmailAddress
 
           If objDictionary.Exists(strSender) Then
              objDictionary.Item(strSender) = objDictionary.Item(strSender) + 1
           Else
              objDictionary.Add strSender, 1
           End If
        End If
    Next

    ' 导出统计结果到Excel
    Set objExcelApp = CreateObject("Excel.Application")
    objExcelApp.Visible = True
    Set objExcelWorkbook = objExcelApp.Workbooks.Add
    Set objExcelWorksheet = objExcelWorkbook.Sheets(1)
 
    With objExcelWorksheet
         .Cells(1, 1) = "Sender"
         .Cells(1, 2) = "Count"
    End With
 
    varSenders = objDictionary.Keys
    varItemCounts = objDictionary.Items
 
    For i = LBound(varSenders) To UBound(varSenders)
        nLastRow = objExcelWorksheet.Range("A" & objExcelWorksheet.Rows.Count).End(xlUp).Row + 1
        With objExcelWorksheet
             .Cells(nLastRow, 1) = varSenders(i)
             .Cells(nLastRow, 2) = varItemCounts(i)
        End With
    Next
 
    objExcelWorksheet.Columns("A:B").AutoFit
End Sub

使用注意事项 #

• 代码开头的TARGET_ACCOUNT常量值，需要替换为Outlook账户列表中显示的账户B的完整邮箱地址，确保和配置的账户名完全一致
• 如果你的"Done"文件夹并非在邮箱根目录下，而是嵌套在收件箱、其他归档文件夹的子层级中，只需要修改定位逻辑：获取对应父文件夹对象后，再遍历其子目录匹配"Done"文件夹即可
• 若存在同名的内部Exchange邮箱的发件人，统计时可补充Sender.GetExchangeUser().PrimarySmtpAddress的逻辑替换原有的SenderEmailAddress取值，避免出现EX类型的地址统计不准确的问题

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