Outlook attachment check - vba

Question

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.

Answer 1

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