Outlook VBA统计发件人邮件数报错：无法找到数字ID求助

问题背景 #

我编写了一个用于统计Outlook收件箱各发件人邮件数量的VBA宏，代码如下：

Sub CountSenderEmails()
    Dim objDictionary As Object
    Dim objInbox 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")
    Set objInbox = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
 
    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

    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

执行时弹出错误提示：“底层安全系统无法找到您的数字ID”

错误原因 #

这个错误核心是Outlook的安全机制触发了数字ID验证：当宏尝试读取SenderEmailAddress这类敏感邮件属性时，Outlook会要求验证数字签名，但系统中没有可用的有效数字证书，导致验证失败。

解决方法 #

方法1：调整Outlook信任中心设置 #

1. 打开Outlook，点击「文件」→「选项」→「信任中心」→「信任中心设置」
2. 进入「宏设置」，选择「启用所有宏」（注意：此选项有安全风险，仅在信任宏来源时使用），或者选择「启用签署的宏」并导入/申请有效数字证书
3. 切换到「电子邮件安全」，检查「数字ID（证书）」列表，确保有可用证书；若没有，可通过系统的证书管理器创建测试证书

方法2：修改代码绕过安全验证 #

替换代码中读取SenderEmailAddress的逻辑，改用PropertyAccessor读取底层属性，避免触发数字ID验证：

' 替换原strSender = objMail.SenderEmailAddress为以下代码
strSender = objMail.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0065001F")

如果读取失败，可降级使用发件人名称作为备选：

On Error Resume Next
strSender = objMail.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0065001F")
If Err.Number <> 0 Then
    strSender = objMail.SenderName
    Err.Clear
End If
On Error GoTo 0

方法3：优化代码效率 #

原代码每次遍历都直接访问objInbox.Items(i)，效率低下且容易触发安全限制，建议先将收件箱项存入集合再遍历，同时添加对象释放逻辑避免内存泄漏。

优化后完整代码 #

Sub CountSenderEmails()
    Dim objDictionary As Object
    Dim objInbox 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
    Dim colItems As Outlook.Items

    Set objDictionary = CreateObject("Scripting.Dictionary")
    Set objInbox = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
    Set colItems = objInbox.Items
    colItems.Sort "[ReceivedTime]", olDescending ' 排序提升遍历效率

    On Error Resume Next
    For i = colItems.Count To 1 Step -1
        If colItems(i).Class = olMail Then
           Set objMail = colItems(i)
           ' 用PropertyAccessor读取邮箱地址，规避安全验证
           strSender = objMail.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0065001F")
           
           ' 读取失败时改用发件人名称
           If Err.Number <> 0 Then
               strSender = objMail.SenderName
               Err.Clear
           End If

           ' 更新字典统计
           If objDictionary.Exists(strSender) Then
              objDictionary.Item(strSender) = objDictionary.Item(strSender) + 1
           Else
              objDictionary.Add strSender, 1
           End If
        End If
    Next
    On Error GoTo 0

    ' 初始化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

    ' 优化写入逻辑，避免重复查找最后一行
    nLastRow = 2
    For i = LBound(varSenders) To UBound(varSenders)
        With objExcelWorksheet
             .Cells(nLastRow, 1) = varSenders(i)
             .Cells(nLastRow, 2) = varItemCounts(i)
        End With
        nLastRow = nLastRow + 1
    Next

    objExcelWorksheet.Columns("A:B").AutoFit
    
    ' 释放对象，避免内存泄漏
    Set objExcelWorksheet = Nothing
    Set objExcelWorkbook = Nothing
    Set objExcelApp = Nothing
    Set objMail = Nothing
    Set colItems = Nothing
    Set objInbox = Nothing
    Set objDictionary = Nothing
End Sub

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