Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'On the next line edit the list of keywords as desired. Be sure to separate each word with a | character.'
Const KEYWORDS = "attached|attachment|attachments|enclosed|enclosure"
'On the next line edit the message that will be displayed when the message should include an attachment as desired.'
Const WARNING_MSG = "Wording in the message suggests that something is attached, but there are no items attached. Do you want to cancel the send and add an attachment?"
'On the next line edit the dialog-box title as desired.'
Const MSG_TITLE = "Attachment Checker"
Dim objRegEx As Object, colMatches As Object, bolAttachment As Boolean, olkAttachment As Outlook.Attachment
Set objRegEx = CreateObject("VBscript.RegExp")
With objRegEx
.IgnoreCase = True
.Pattern = KEYWORDS
.Global = True
End With
Set colMatches = objRegEx.Execute(Item.Body)
If colMatches.count > 0 Then
For Each olkAttachment In Item.Attachments
If olkAttachment.Type <> olEmbeddeditem Then
bolAttachment = True
Exit For
End If
Next
If Not bolAttachment Then
If msgbox(WARNING_MSG, vbQuestion + vbYesNo, MSG_TITLE) = vbYes Then
Cancel = True
End If
End If
End If
Set olkAttachment = Nothing
Set colMatches = Nothing
Set objRegEx = Nothing
End Sub
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'On the next line edit the list of keywords as desired. Be sure to separate each word with a | character.'
Const KEYWORDS = "attached|attachment|attachments|enclosed|enclosure"
'On the next line edit the message that will be displayed when the message should include an attachment as desired.'
Const WARNING_MSG = "Wording in the message suggests that something is attached, but there are no items attached. Do you want to cancel the send and add an attachment?"
'On the next line edit the dialog-box title as desired.'
Const MSG_TITLE = "Attachment Checker"
Dim objRegEx As Object, colMatches As Object, bolAttachment As Boolean, olkAttachment As Outlook.Attachment
Set objRegEx = CreateObject("VBscript.RegExp")
With objRegEx
.IgnoreCase = True
.Pattern = KEYWORDS
.Global = True
End With
Set colMatches = objRegEx.Execute(Item.Body)
If colMatches.count > 0 Then
For Each olkAttachment In Item.Attachments
If Not IsEmbedded(olkAttachment) Then
bolAttachment = True
Exit For
End If
Next
If Not bolAttachment Then
If msgbox(WARNING_MSG, vbQuestion + vbYesNo, MSG_TITLE) = vbYes Then
Cancel = True
End If
End If
End If
Set olkAttachment = Nothing
Set colMatches = Nothing
Set objRegEx = Nothing
End Sub
Function IsEmbedded(olkAttachment As Outlook.Attachment) As Boolean
'Purpose: Determines if an attachment is embedded.'
'Written: 9/14/2009'
'Author: BlueDevilFan'
'Outlook: 2007'
Dim olkPA As Outlook.PropertyAccessor
Set olkPA = olkAttachment.PropertyAccessor
On Error Resume Next
IsEmbedded = (olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001E") <> "")
On Error GoTo 0
Set olkPA = Nothing
End Function
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (66)
Author
Commented:Commented:
You need to change:
Open in new window
ToOpen in new window
And change:
Open in new window
ToOpen in new window
Commented:
Commented:
Commented:
View More