如何使用VB.NET在Outlook Classic中解密并归档S/MIME加密邮件？

需求背景 #

在Windows 10/11系统中，使用Outlook Classic（桌面版2016及以上），通过VB.NET结合Microsoft Outlook Interop实现：

1. 检测S/MIME加密邮件
2. 自动解密邮件
3. 将解密后的邮件以.msg格式归档到本地文件夹

当前已能访问普通邮件，但需解决以下问题：

• 如何识别S/MIME加密邮件
• 如何确认邮件已成功解密
• 如何正确保存解密后的邮件版本

尝试的初始代码 #

Private Sub ArchiveDecryptedSMIME()
    Dim app As New Outlook.Application()
    Dim ns As Outlook.NameSpace = app.GetNamespace("MAPI")
    Dim inbox As Outlook.MAPIFolder = ns.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)

    For Each item In inbox.Items
        If TypeOf item Is Outlook.MailItem Then
            Dim mail As Outlook.MailItem = CType(item, Outlook.MailItem)
            ' Assuming mail is decrypted if certificate is installed and mail opens normally

            If mail.Subject IsNot Nothing Then
                mail.SaveAs("C:\ArchivedMails\" & mail.Subject & ".msg", Outlook.OlSaveAsType.olMSGUnicode)
            End If
        End If
    Next
End Sub

解决方案实现 #

1. 检测S/MIME加密邮件 #

通过Outlook的PropertyAccessor读取MAPI属性PR_SECURITY_FLAGS（标识为http://schemas.microsoft.com/mapi/proptag/0x0E070003），当该属性值与1（对应olEncrypted）按位与结果为1时，说明邮件是S/MIME加密状态。

2. 确认邮件已解密 #

访问加密邮件的Body或HTMLBody属性会触发Outlook自动解密（前提是本地有匹配的证书）。解密完成后，PR_SECURITY_FLAGS的加密标记会被移除，可再次读取该属性确认解密状态；同时也可检查Body是否为空来判断解密是否成功。

3. 保存解密后的邮件 #

解密后的邮件直接调用SaveAs方法，指定olMSGUnicode格式即可。需注意处理文件名中的非法字符，以及避免重复文件名覆盖问题。

完整修正代码 #

Private Sub ArchiveDecryptedSMIME()
    Dim app As New Outlook.Application()
    Dim ns As Outlook.NameSpace = app.GetNamespace("MAPI")
    Dim inbox As Outlook.MAPIFolder = ns.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)
    Dim archivePath As String = "C:\ArchivedMails\"
    
    ' 创建归档文件夹（如果不存在）
    If Not IO.Directory.Exists(archivePath) Then
        IO.Directory.CreateDirectory(archivePath)
    End If

    For Each item In inbox.Items
        If TypeOf item Is Outlook.MailItem Then
            Dim mail As Outlook.MailItem = CType(item, Outlook.MailItem)
            Dim propAccessor As Outlook.PropertyAccessor = mail.PropertyAccessor
            Dim securityFlags As Integer = 0
            
            Try
                ' 读取PR_SECURITY_FLAGS属性判断加密状态
                securityFlags = CInt(propAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E070003"))
            Catch
                ' 非加密邮件可能读取失败，直接跳过
                Continue For
            End Try

            ' 检测是否为S/MIME加密邮件
            If (securityFlags And 1) = 1 Then
                Try
                    ' 访问Body触发Outlook自动解密（需本地有对应证书）
                    Dim unusedBody As String = mail.Body
                    
                    ' 再次读取属性确认解密成功
                    securityFlags = CInt(propAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E070003"))
                    If (securityFlags And 1) <> 1 Then
                        ' 生成唯一文件名，替换非法字符
                        Dim baseFileName As String = $"{mail.Subject}_{DateTime.Now.Ticks}"
                        Dim safeFileName As String = ReplaceInvalidFileNameChars(baseFileName)
                        Dim fullSavePath As String = IO.Path.Combine(archivePath, $"{safeFileName}.msg")
                        
                        ' 保存解密后的邮件
                        mail.SaveAs(fullSavePath, Outlook.OlSaveAsType.olMSGUnicode)
                        Console.WriteLine($"已归档解密邮件: {fullSavePath}")
                    Else
                        Console.WriteLine($"邮件解密失败: {mail.Subject}")
                    End If
                Catch ex As Exception
                    Console.WriteLine($"处理邮件出错 [{mail.Subject}]: {ex.Message}")
                End Try
            End If
        End If
    Next
End Sub

' 辅助方法：替换文件名中的非法字符
Private Function ReplaceInvalidFileNameChars(fileName As String) As String
    Dim invalidChars() As Char = IO.Path.GetInvalidFileNameChars()
    For Each c As Char In invalidChars
        fileName = fileName.Replace(c.ToString(), "_")
    Next
    Return fileName
End Function

优化建议 #

• 过滤加密邮件提升效率：处理大量邮件时，使用Items.Restrict方法提前过滤加密邮件，避免遍历所有邮件：

  ' 构建过滤条件，仅获取加密邮件
  Dim filter As String = "@SQL=""http://schemas.microsoft.com/mapi/proptag/0x0E070003"" & 1 = 1"
  Dim encryptedItems As Outlook.Items = inbox.Items.Restrict(filter)
  
  ' 遍历过滤后的加密邮件
  For Each item In encryptedItems
      ' 后续处理逻辑...
  Next
  

• 证书依赖：确保本地安装了对应S/MIME解密证书，且Outlook能手动解密目标邮件，否则自动解密会失败。

内容的提问来源于stack exchange，提问作者Ankit-k