Check if email attachment is password protected before sending

问题

I'm trying to check all my attachments before sending an email to see if they are password protected. Typically these will be Word, Excel or PowerPoint files.

I've got as far as seeing if there are attachments.

I don't know how to loop through each attachment in the mail file to see if each one is password protected.

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

回答1:

The code below does not solve your issue, but does show how to check documents and databases to see if password protected. If you are able to obtain the file path, then this code could be modified to pass the path and filename, then return a flag to indicate PW status. Or just modify and embed this code in your module.

Revision 1: Instead of trying to find the path of the file to check for a password, an alternate solution would be for your code to save the file to a temp folder, then delete when finished. The following line of code will give you a temp folder (i.e. C:\Users\MyName\AppData\Local\Temp)

strFolder = objFSO.GetSpecialFolder(2)

This idea was obtained from a post that allows you to rename attachments: http://www.flobee.net/rename-outlook-attachments-before-you-send-them/

Also, the OP need to consider how to implement/perform the password check. If the code is called 'automatically', then unless you have some rule to only check certain files, then your code will always check ALL attachments for ALL emails! I doubt that's what you want to happen. Perhaps a user button on the tool bar?

Original Code:

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

来源：https://stackoverflow.com/questions/47313337/check-if-email-attachment-is-password-protected-before-sending

标签

vba

outlook-vba

email-attachments