发送前检查电子邮件附件是否受密码保护

Question

我正在尝试在发送电子邮件之前检查我的所有附件，看看它们是否受密码保护。这些通常是 Word、Excel 或 PowerPoint 文件。

我看看有没有附件。

我不知道如何遍历邮件文件中的每个附件以查看每个附件是否受密码保护。

Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

Dim attachments2 As Outlook.attachments
Dim attachm As Outlook.Attachment

If Item.attachments.Count > 0 Then

    Set attachments2 = Item.attachments

    Set attachm = Item.Attachment

    For Each attachm In attachments2

    ' ***IM GUESSING CODE TO CHECK IF ATTACHMENTS ARE PROTECTED WOULD GO IN HERE?***

    Next

End If

End Sub

Answer 1

下面的代码不能解决您的问题，但确实显示了如何检查文档和数据库以查看密码是否受保护。如果能够获取文件路径，则可以修改此代码以传递路径和文件名，然后返回一个标志以指示 PW 状态。或者只是修改此代码并将其嵌入到您的模块中。

修订版 1：与其尝试查找文件的路径来检查密码，另一种解决方案是让您的代码将文件保存到临时文件夹，然后在完成后删除。以下代码行将为您提供一个临时文件夹（即 C:\Users\MyName\AppData\Local\Temp）

strFolder = objFSO.GetSpecialFolder(2)

这个想法来自一个允许你重命名附件的帖子：http://www.flobee.net/rename-outlook-attachments-before-you-send-them/

此外，OP 需要考虑如何实施/执行密码检查。如果代码被称为“自动”，那么除非您有一些规则只检查某些文件，否则您的代码将始终检查所有电子邮件的所有附件！我怀疑这就是你想要发生的事情。也许是工具栏上的用户按钮？

原代码：

Option Compare Database
Option Explicit

Public Function Check_For_Passwords()
Dim objWord     As Word.Application
Dim objWordDoc  As Word.Document
Dim sPath       As String
Dim sFileName   As String
Dim oAccess     As Access.Application

    On Error GoTo Error_Trap

    ' Set the following string to the path of your Word Document
    sPath = "C:\data\WP\"                   ' <<< CHANGE THIS!!
    sFileName = "Access.doc"                ' <<< CHANGE THIS!!
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = False
    ' Use a fake password - if no password on doc, OK; If password protected will fail
    Set objWordDoc = objWord.Documents.Open(sPath & sFileName, , True, , "*****")
    'Err: 5408    The password is incorrect. Word cannot open the document.

    Set oAccess = CreateObject("Access.Application")
    oAccess.Visible = False
    sPath = "C:\data\Access\"                   ' <<< CHANGE THIS!!
    sFileName = "PWD_DB.mdb"                    ' <<< CHANGE THIS!!

    'If error, then database has password
    oAccess.DBEngine.OpenDatabase sPath & sFileName, False
    'Err: 3031    Not a valid password.

    Exit Function

Error_Trap:
    If Err.Number = 5408 Then
        MsgBox "Document has a password! Do whatever...  " & sPath & sFileName
    ElseIf Err.Number = 3031 Then
        MsgBox "Access DB has a password! Do whatever...  " & sPath & sFileName
    Else
        MsgBox "Unexpected error: " * Err.Number & vbTab & Err.Description
    End If
End Function