Identify MS Excel or MS Access attachments and warn to check contents

问题

Personal identifying information (PII) is often inadvertently transmitted through non-encrypted emails. Most of the times these data are stored in Excel or Access spreadsheets.

I'd like to identify Access or Excel attachments after hitting send and ask "There are Access or Excel files attached to this email, are you sure these do not contain PII?"

The criteria for identifying "xlsx" or "accdb" in the attachment name I just don't get.

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

If Right([attachment_Name],4) = xlsx then

    answer = MsgBox("There are Access or Excel files attached to this email, are you sure these do not contain PHI?",vbYesNo)

    If answer = vbNo 
        Cancel = True
    Else

    End If

End If

End Sub

回答1:

Here's the code you're looking for:

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

Dim bolSensitiveAttach As Boolean
Dim answer As Double

Set Msg = Item

bolSensitiveAttach = False
If Msg.Attachments.Count > 0 Then
    For i = 1 To Msg.Attachments.Count
         If Right(Msg.Attachments(i).FileName, 3) = "xls" Or  _
                Left(Right(Msg.Attachments(i).FileName, 4), 3) = "xls" Or _
                Right(Msg.Attachments(i).FileName, 5) = "accdb" Or _
                Right(Msg.Attachments(i).FileName, 3) = "mdb" Then  
                     bolSensitiveAttach = True
         End If

    Next i
End If

If bolSensitiveAttach = True Then
    answer = MsgBox("There are Access or Excel files attached to this" _
                 & "mail, are you sure these do not contain PHI?", vbYesNo)
    If answer = vbNo Then
        Cancel = True
    End If
End If

End Sub

Hope this helps.

EDITED TO INCLUDE .mdb extension and xls* extensions (xlsm, xlsx...) instead of just xlsx. Thanks for the suggestion Parfait.

回答2:

You could use the FileSystemObject to grab the extension:

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

    Dim olAtt As Attachment
    Dim oFSO As Object
    Dim sExt As String
    Dim bSafe As Boolean

    If Item.Attachments.Count > 0 Then
        bSafe = True
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        For Each olAtt In Item.Attachments
            sExt = oFSO.GetExtensionName(olAtt.FileName)
            If sExt Like "xls*" Or sExt Like "accd*" Or sExt = "mdb" Then
                bSafe = False
                Exit For
            End If
        Next olAtt

        If Not bSafe Then
            If MsgBox("This email contains an Access or Excel file." & vbCr & _
                      "Do you wish to continue?", vbCritical + vbYesNo) = vbNo Then
                Cancel = True
            End If
        End If

        Set oFSO = Nothing

    End If
End Sub

I've included for Access, but pretty sure that doesn't send by default.

来源：https://stackoverflow.com/questions/28509063/identify-ms-excel-or-ms-access-attachments-and-warn-to-check-contents

标签

vba

outlook

attachment

mailitem