Check to see if Outlook has an attachment and is going to an outside domain

[Tarver]

Well, I blew it. I accidentally replied to an email that included people outside my company and attached a file with confidential data. It was a huge error, like giving away the nuclear codes.

So now that I still have a job, I'm looking to make sure that never happens again. I'm trying to create a VBA solution in Outlook that gives me a popup IF A) I'm sending to an outside doman and B) I'm including an attachment.

I found the following online here. It works well to alert me when I'm sending to an outside domain.

PrivateSub Application_ItemSend(ByVal Item AsObject, Cancel AsBoolean)Dim recips As Outlook.Recipients
    Dim recip As Outlook.Recipient
    Dim pa As Outlook.PropertyAccessor
    Dim prompt AsString
    Dim strMsg AsString

    Const PR_SMTP_ADDRESS AsString="http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

    Set recips = Item.Recipients
    ForEach recip In recips
        Set pa = recip.PropertyAccessor
        If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)),"@example.com")=0Then
            strMsg = strMsg &"   "& pa.GetProperty(PR_SMTP_ADDRESS)& vbNewLine
        EndIf
    Next

    If strMsg <>""Then
        prompt ="This email will be sent outside of example.com to:"& vbNewLine & strMsg &"Do you want to proceed?"
        If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground,"Check Address")= vbNo Then
            Cancel =True
        EndIf
    EndIfEndSub

I think the code I need to check for attachments is:

Item.Attachements.Count > 0

However, when I put them together like this, I get an Object doesn’t support this property or method error.

If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@example.com") = 0 And Item.Attachements.Count > 0 Then

Could anyone help me modify the code above to also check for attachments?

I appreciate any advice you can offer!

Thanks.

 

[John_w]

You misspelt Attachments. Try:

Item.Attachments.Count > 0

 

[Tarver]

I can't believe I made that error. Thanks.

I am still trying to get this code to work, however. When the Item.Attachments.Count is greater than 0, the code stops sending outside of the organization. However, logos and images in the email are also counted as attachments. Is there a way to isolate JUST the files that are attached and not in the body of the message?

 

[John_w]

Tested only from Excel, not within Outlook, but try incorporating this into your Application_ItemSend code.

Sub X()
    Dim outMailItem As MailItem
    Dim outAttachment As Attachment
    Dim HTMLdoc As Object
    Dim img As Object
    Dim HTMLImgSrc As String
    Dim embedded As Boolean
    Dim fileAttachment As Boolean, numFileAttachments As Long

    Set outMailItem = Item  'the Application_ItemSend Item parameter - you might need to check that the Item object is an email before assigning it to a MailItem

    HTMLImgSrc = ""
    
    If outMailItem.BodyFormat = olFormatHTML Then   
        'Get src attribute in every HTML img tag
        Set HTMLdoc = CreateObject("HTMLfile")
        HTMLdoc.Open
        HTMLdoc.Write outMailItem.HTMLBody
        HTMLdoc.Close
        For Each img In HTMLdoc.getElementsByTagName("IMG")
            HTMLImgSrc = HTMLImgSrc & img.src & " "
        Next               
    End If
    
    numFileAttachments = 0
    
    For Each outAttachment In outMailItem.Attachments
        Debug.Print outAttachment.Filename
      
        fileAttachment = IsFileAttachment(outAttachment, HTMLImgSrc)
        If fileAttachment Then
            numFileAttachments = numFileAttachments + 1
            Debug.Print "File attachment" & vbCrLf
        Else
            Debug.Print "Embedded attachment" & vbCrLf
        End If
        
    Next

    MsgBox "Number of file attachments in this email = " & numFileAttachments
End Sub

Calls this function, which determines whether the attachment is a file or not:

Private Function IsFileAttachment(outAttachment As Outlook.Attachment, allImgSrc As String) As Boolean

    'Returns True is the attachment is a file attachment, or False if it's a embedded or inline attachment

    Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
    Const PR_ATTACH_MIME_TAG As String = "http://schemas.microsoft.com/mapi/proptag/0x370E001E"
    Const PR_ATTACH_FLAGS As String = "http://schemas.microsoft.com/mapi/proptag/0x37140003"
    Const PR_ATTACH_CONTENT_LOCATION As String = "http://schemas.microsoft.com/mapi/proptag/0x3713001E"

    Dim outPropertyAccessor As PropertyAccessor
    Dim propertyValue As Variant

    IsFileAttachment = True
    
    If outAttachment.Type <> olByValue Then IsFileAttachment = False
    
    If IsFileAttachment Then
        Set outPropertyAccessor = outAttachment.PropertyAccessor
        propertyValue = outPropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID)
        Debug.Print "ATTACH_CONTENT_ID = "; propertyValue
        'The existence of a PR_ATTACH_CONTENT_ID property value doesn't necessarily mean that the attachment is not a file attachment.
        'For example, Gmail assigns a PR_ATTACH_CONTENT_ID property to each file attachment
        'If the ContentID occurs in a HTML img src attribute it means the attachment is embedded in the email body and therefore not a file attachment
        If InStr(1, allImgSrc, "cid:" & propertyValue, vbTextCompare) Then IsFileAttachment = False
    End If
        
    If IsFileAttachment Then
        propertyValue = outPropertyAccessor.GetProperty(PR_ATTACH_MIME_TAG)
        Debug.Print "ATTACH_MIME_TAG = "; propertyValue
        If propertyValue = vbNullString Then IsFileAttachment = False
    End If
        
    If IsFileAttachment Then
        propertyValue = outPropertyAccessor.GetProperty(PR_ATTACH_FLAGS)
        Debug.Print "ATTACH_FLAGS = "; propertyValue
        If propertyValue = 4 Then IsFileAttachment = False 'the attachment is embedded
    End If

    If IsFileAttachment Then
        propertyValue = outPropertyAccessor.GetProperty(PR_ATTACH_CONTENT_LOCATION)
        Debug.Print "ATTACH_CONTENT_LOCATION = "; propertyValue
        If propertyValue <> vbNullString Then IsFileAttachment = False
    End If

End Function

 

[JornHerbrand]

I have tested the IsFileAttachment function for some time and it works fine, but today I discovered that the function return false even when there is a pdf file attached in the email.

It is the following line that will produce a nullstring:
propertyValue = outPropertyAccessor.GetProperty(PR_ATTACH_MIME_TAG)

Wy is this happening?

 

[John_w]

Welcome to MrExcel forums.

Same here, on Outlook 2016. The GetProperty calls which returned sensible strings or values last year now return null strings or zero. It seems to occur with any type of attachment - I tested it with .pdf and .jpg files. I don't know why this happens; maybe something in an Outlook update has changed, such that these properties are no longer available.

 

[JornHerbrand]

Could I just skip the PR_ATTACH_MIME_TAG test to make it work, or do you plan to update the IsFileAttachment function

 

[John_w]

You could try skipping the PR_ATTACH_MIME_TAG check, however all the GetProperty checks are necessary to determine whether the attachment is true file attachment or not. As I said, I've checked the code and now all the property checks return an empty string, except PR_ATTACH_FLAGS which returns zero. I don't know how the IsFileAttachment function can be fixed to work correctly.