CODEWITHSUNDEEP
vbaemailoutlookattachmentemail-attachments
Mads Stecher
Mads Stecher

Reputation: 15

Outlook attachment check

How do I make a VBA code or set up my mail in a way so that a message box shows up if I am sending an email with an attachment? I have searched through many posts and haven't found a solution to this problem - I have found many solutions to check for missing attachments but so far I haven't found one where an alert is shown if an email has an attachment.

Upvotes: 0

Views: 1630

Answers (1)

Mike
Mike

Reputation: 644

I would reference https://learn.microsoft.com/en-us/office/vba/api/Outlook.Application.ItemSend

and How can I automatically run a macro when an email is sent in Outlook?

as well as https://social.msdn.microsoft.com/Forums/sqlserver/en-US/c4f47790-8e7b-425a-bf7e-f7bc5b725e81/determine-attechments-in-mail-item?forum=outlookdev

These detail the ItemSend event with the example shown below.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim prompt As String
prompt = "Are you sure you want to send " & Item.Subject & "?"
If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then
    Cancel = True
    End If
End Sub

The property of the MailItem you're looking for is Attachments.

The above example passes in the Item as an object-which should be a MailItem by default, so checking Item.Attachments.Count <> 0 would be true if it had attachments.

Try something along the lines of

Private Sub Application_ItemSend(ByVal Item as Object, Cancel as Boolean)
If Item.Attachments.Count > 0 Then
   If Msgbox("Items attached to email. Send?", vbYesNo) = vbNo Then
     Cancel = True
   End If
End If
End Sub

To only flag messages with attachments at the subject line we can use the Attachment Property "PR_ATTACHMENT_HIDDEN" If it exists and the value is FALSE, it indicates an attached-at-subject-line attachment as opposed to an embedded image.

The quick On Error Resume Next is to catch the exception if PR_ATTACHMENT_HIDDEN isn't on any objects. It will throw an exception if it doesn't exist.

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

Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"

Dim aFound As Boolean

aFound = False

    If TypeOf Item Is Outlook.MailItem Then

        For Each a In Item.Attachments
            On Error Resume Next ' to avoid the error thrown when no items within attachments have this property

            If a.PropertyAccessor.GetProperty(PR_ATTACHMENT_HIDDEN) = False Then
                aFound = True
                Exit For
            End If

            On Error GoTo 0
         Next a

        If aFound = True Then
            If MsgBox("Items attached to email. Send?", vbYesNo) = vbNo Then
                Cancel = True
            End If
        End If
    End If
End Sub

If you are trying to discriminate between images within signatures and embedded images we need to review the content ID against the HTML body of the email for the tag. I added another check to the code to find those and disregard them as false positives.

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

Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"

Dim aFound As Boolean

aFound = False

    If TypeOf Item Is Outlook.MailItem Then

        For Each a In Item.Attachments
            On Error Resume Next ' to avoid the error thrown when no items within attachments have this property
            If a.PropertyAccessor.GetProperty(PR_ATTACHMENT_HIDDEN) = False Then
                If Len(a.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID)) > 0 And InStr(Application.ActiveInspector.CurrentItem.HTMLBody, a.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID)) Then
                Else
                aFound = True
                Exit For
                End If
            End If

            On Error GoTo 0
         Next a

        If aFound = True Then
            If MsgBox("Items attached to email. Send?", vbYesNo) = vbNo Then
                Cancel = True
            End If
        End If
    End If
End Sub

Upvotes: 2

Related Questions