Outlook Technologies

Outlook Forms

Languages

Samples

More Outlook Resource Sites

Microsoft Developer Network (MSDN)

FAQs and other general resources

share code 02-Sep-2010 22:30

Looking for help with Outlook programming projects — VSTO, add-ins, VBA, custom Outlook forms, etc.? You′ve come to the right place!

NEW! >> Subscribe to this site via RSS. For more RSS options, see the complete list of feeds on our main news page.

Code level: intermediate Code area: Basic Outlook Printer Friendly Version
Title: Attachment checker 1.0
Description: This is my final attempt (for now) at making an attachment checker. This event procedure will check an outgoing message, first for a blank Subject, then the Subject and Body to see if an attachment should be attached (based on keyword/phrases). Most of the functionality is explained in the procedure notes and code comments. It's working for me, hopefully it will work for you. The hard part was working with html message bodies.
Date: 23-Aug-2004 13:41
Code level: intermediate
Code area: Basic Outlook
Posted by: Jeremy Gollehon
Body: '------------------------------------------------------------------------------------------ ' Procedure : Jeremy's Application_ItemSend Event 1.0 ' Author : Jeremy Gollehon ' Purpose : Warn on blank Subject line and/or no attachment (using keyword check). ' Program works with all message types (only tested in Outlook 2003). ' ' DateTime : 7/05/2004, - Original concept code ' : 8/17/2004, - Some optimization and fixing of logic errors. ' : 8/18/2004, - Added functionality for all message types. ' - Now searches Subject and Body for keywords. ' - In Reply/forward's only non-quoted section of body is searched. ' : 8/19/2004, - (Armen Stein) Changed array declaration to a Split, so that new ' search words can be easily added in a constant. ' : 8/20/2004, - Check to make sure code only runs on MailItem type. ' : 8/23/2004 - Added ExactMatch function: check's to be sure the exact ' keyword/keyphrase was found. Eg. "here it is" vs "where it is" ' - Added EmbeddedAttachCount function (code mostly taken from ' Outlookcode.com). It's used to determine the number of embedded ' attachments and exlude them from the attachment count. This code ' uses the Redemption dll (http://www.dimastr.com/redemption) ' which must be installed/registered in Windows, and referenced, ' Tools> References...> SafeOutlook Library, in Outlook VBA. '------------------------------------------------------------------------------------------ Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) Dim bCancelSend As Boolean Dim sTextToSearch As String Dim sKeyWords As String Dim vKeyWords() As String Dim iStartOfQuote As Long Dim iAttachmentCount As Long Dim i As Long If TypeName(Item) <> "MailItem" Then Exit Sub 'Add keywords/phrases here. Use lowercase words in the following array. sKeyWords = "attach;attached;attachment;enclosed;here's;here it is" 'CHECK FOR BLANK SUBJECT LINE If Item.Subject = "" Then bCancelSend = MsgBox("This message does not have a subject." & vbNewLine & _ "Do you wish to continue sending anyway?", _ vbYesNo + vbExclamation, "No Subject") = vbNo End If 'CHECK BODY AND SUBJECT FOR ATTACMENT KEYWORDS. 'Set TextToSearch variable to message Body based 'on message type and find start of quoted text. Select Case Item.BodyFormat Case olFormatHTML iStartOfQuote = InStr(Item.HTMLBody, "<DIV class=OutlookMessageHeader") - 1 sTextToSearch = Item.HTMLBody Case olFormatRichText iStartOfQuote = InStr(Item.Body, "_____________________________________________") - 1 sTextToSearch = Item.Body Case olFormatPlain iStartOfQuote = InStr(Item.Body, "-----Original Message-----") - 1 sTextToSearch = Item.Body End Select 'Adjust TextToSearch if there is quoted text If iStartOfQuote > 0 Then sTextToSearch = Left(sTextToSearch, iStartOfQuote) 'Add Subject to the search text if not a Reply If Left(Item.Subject, 3) <> "RE:" Then sTextToSearch = Item.Subject & " " & sTextToSearch End If 'Change to all lowercase for string comparison sTextToSearch = LCase(sTextToSearch) 'Replace undesired characters with spaces to help with ExactMatch function sTextToSearch = Replace(sTextToSearch, ",", " ") sTextToSearch = Replace(sTextToSearch, ".", " ") sTextToSearch = Replace(sTextToSearch, "?", " ") sTextToSearch = Replace(sTextToSearch, "!", " ") sTextToSearch = Replace(sTextToSearch, Chr(34), " ") 'quotes sTextToSearch = Replace(sTextToSearch, "<", " ") 'beginning of html tag sTextToSearch = Replace(sTextToSearch, ">", " ") 'end of html tag sTextToSearch = Replace(sTextToSearch, "&", " ") 'beginning of html Character Entities sTextToSearch = Replace(sTextToSearch, ";", " ") 'end of html Character Entities 'Start the search If Not bCancelSend Then iAttachmentCount = Item.Attachments.Count - EmbeddedAttachCount(Item) If iAttachmentCount = 0 Then vKeyWords = Split(sKeyWords, ";") For i = LBound(vKeyWords) To UBound(vKeyWords) If InStr(sTextToSearch, vKeyWords(i)) > 0 Then If StrExactMatch(sTextToSearch, vKeyWords(i)) Then bCancelSend = MsgBox("It appears you were going to send an attachment but nothing is attached." & vbNewLine & _ "Do you wish to continue sending anyway?" & vbNewLine & vbNewLine & _ "Word/Phrase found: " & vKeyWords(i), _ vbYesNo + vbExclamation, "Attachment Not Found") = vbNo Exit For End If End If Next i End If End If 'Cancel sending message if answered yes to either message box. Cancel = bCancelSend End Sub Function EmbeddedAttachCount(Item As MailItem) ' Function built from code found at OutlookCode.com ' Returns count of attachments found in message body ' that contain CID's. Dim oSMail As Redemption.SafeMailItem Dim oAtt As Redemption.Attachment Dim sCID As String Dim iCount As Long Set oSMail = CreateObject("Redemption.SafeMailItem") oSMail.Item = Item For Each oAtt In oSMail.Attachments sCID = oAtt.Fields(&H3712001E) If sCID <> "" Then iCount = iCount + 1 Next EmbeddedAttachCount = iCount Set oSMail = Nothing Set oAtt = Nothing End Function Function StrExactMatch(sLookIn As String, sLookFor As String) As Boolean '- Add padding to sLookin in case sLookfor is at ' the very beginning or very end of the sLookIn. '- Add padding to sLookFor to ensure an exact match StrExactMatch = InStr(" " & sLookIn & " ", " " & sLookFor & " ") > 0 End Function
All 39comments

	Page [ 1 2 3 4 Next >> ]
	jsonnabend 26-Aug-2004 12:15 Love your code. I'm adapting it to run as a function called from my own ItemSend event. One issue comes up, which I've run into before. The line: Dim oSMail As Redemption.SafeMailItem gives me an error of "User-defined type not defined". I have Redemption installed and use it in my own code. How do I properly define this type? TIA. - Jeff
	jsonnabend 26-Aug-2004 12:31 Got it. I needed to import the type library (or the reference, or whatever, in VBA-speak).
	Jeremy Gollehon 26-Aug-2004 13:13 Hi Jeff, Glad you like the code and that you got it working. One thing. I did notice that I could take out one sort of redundant line from the code. The line in the search loop: If InStr(sTextToSearch, vKeyWords(i)) > 0 Then isn't really needed. It doesn't save any time as the ExactMatch function is a one liner anyway. -Jeremy
	Brent Weight 30-Aug-2004 13:22 I tried an earlier version of the code and updated to this one. However, I do not have Redemption and I don't know what it is. Can you please advise! Thanks
	Sue Mosher 30-Aug-2004 14:55 Redemption is a third-party library that wraps Extended MAPI to avoid security prompts and provide functionality that the Outlook object model doesn't contain -- http://www.dimastr.com/redemption/
	Jeremy Gollehon 31-Aug-2004 11:31 Simple instructions on how to install Redemption. 1) At http://www.dimastr.com/redemption, click Download. 2) On the download page click "Download Developer version" 3) Save to somewhere on your computer, unzip and run the .exe file. The installer puts a dll in your Program Files directory and registers it with Windows. 4) In the Outlook VBE go to Tools > References and set an active reference to SafeOutlook Library. 5) You may have to restart Outlook.
	bob peck 06-Oct-2004 07:28 I've been trying to bash together two bits of code, the one above and another that forwards the selected message. What I'm trying to achieve is to search the selected message for the name of a sports centre and use this to create an email address to forward the original message to (in this case by concatenating "LF, " and the sports centre name which is recognised as a valid address in outlook in my office). Since I'll only ever be forwarding messages that contain the centre name after the text "::::: C L O S E S T C L U B :::::" since they're sent via a web form I've tried to adapt Jeremy's code to specify the text to be searched should always be to the right of this text. The first line I'm getting stuck at when trying to run the code (below) is: sTextToSearch = Item.Body No doubt something to do with the way I've combined the two routines. Anyone have any ideas or know of another already created code that will do the job I'm after? Cheers Bobwhosmiles Sub FwdWebinfo() Dim objApp As Application Dim objSelection As Selection Dim blnDoIt As Boolean Dim i As Integer Dim strMsg As String Set objApp = CreateObject("Outlook.Application") Set objSelection = objApp.ActiveExplorer.Selection blnDoIt = False ' If no messages selected, tell the user If objSelection.Count = 0 Then Call Email_not_selected ElseIf objSelection.Count = 1 Then ' 1 message selected, just do it blnDoIt = True Else ' more than 1 messge is selected so warn user strMsg = "Only select one message at a time to forward" i = MsgBox( _ Prompt:=strMsg, _ Buttons:=vbOKOnly + vbDefaultButton0, _ Title:="Multiple Selection") Exit Sub End If If blnDoIt = True Then Call Fwd_selected_items(objSelection) Beep ' alert the user that we're done End If Set objSelection = Nothing Set objApp = Nothing End Sub ' Tell user that no email message was selected ' Sub Email_not_selected() Dim i As Integer i = MsgBox(Prompt:="You need to select a message or messages to forward", _ Buttons:=vbDefaultButton2, _ Title:="Unrecognized Selection") End Sub ' For selected message, send to the appropriate email address ' Sub Fwd_selected_item(objSel As Selection) Dim objItem As Object Dim intOKToExceedMax As Integer Dim iStartOfQuote As Long Dim sTextToSearch As String Dim sKeyWords As String Dim vKeyWords() As String Dim iCentreToReceive As String Dim i As Long sKeyWords = "Bellahouston;Castlemilk;Donald_;Drumchapel;Easterhouse;Haghill;Gorbals;Holyrood;Kelvinhall;Maryhill;Nethercraigs;Northwoodside;Pollock;Scotstoun;Tollcross;Whitehill;Yoker" sTextToSearch = Item.Body iStartOfQuote = InStr(Item.Body, "::::: C L O S E S T C L U B :::::") - 1 If iStartOfQuote > 0 Then sTextToSearch = Right(sTextToSearch, iStartOfQuote) vKeyWords = Split(sKeyWords, ";") For i = LBound(vKeyWords) To UBound(vKeyWords) If InStr(sTextToSearch, vKeyWords(i)) > 0 Then iCentreToReceive = vKeyWords(i) Exit For End If Next i For Each objItem In objSel ' Forward to the specified mail address Set myForward = objItem.Forward myForward.Recipients.Add "LF, " & iCentreToReceive myForward.Send Next Set myForward = Nothing Set objItem = Nothing End Sub
	Sue Mosher 06-Oct-2004 08:48 Bob, see my response to your post at http://www.outlookcode.com/threads.aspx?forumid=2&messageid=7641
	Rollo 13-Oct-2004 11:55 Hi all, I'm new in this site - lots of interesting info. Sue, I'd like to kindly ask about the above code - I found another code you posted here -> http://www.winnetmag.com/MicrosoftExchangeOutlook/Article/ArticleID/27217/27217.html The question is really simple - How should I create the macro, from scratch ? I actually need a beginner instructions, since I'm not familiar with VBA. Where should I insert this code ? how to create a macro ? and how to make it run every time outlook 2003 starts ? thanks, Rollo
	Sue Mosher 13-Oct-2004 17:50 Rollo, if you're new to Outlook VBA macros, these web pages should help you get started: http://www.winnetmag.com/Articles/Index.cfm?ArticleID=21522&pg=1 http://www.outlookcode.com/d/vb.htm
	Page [ 1 2 3 4 Next >> ]

name email