Outlook

Automatically Save, Remove, and Comment incoming email attachments

Ease of Use

Intermediate

Version tested with

2003,2007 

Submitted by:

Charlize

Description:

Receives an incoming email attachment, saves it to a predetermined folder using specified file naming convention. Then removes attachment from email body while simultaneously commenting email with attachment's location. 

Discussion:

When you receive a lot of word and excel files the limit of your storage inbox could be reached very quickly. This example will strip all Word and Excel files, and save them to the folder you specify. An extra line is added at the bottom of the message for every attached file that is saved and removed from the incoming mail. 

Code:

instructions for use

			

Option Explicit Option Compare Text 'Created by : Charlize 'Revised by : Oorang ' Rewrote a call and jump loop to a Do Until Loop ' Instead of the original if's for the ' attachments, he came up with an array ' of file extensions (pretty slick) 'Rerevised by : Charlize 'Submitted by : Charlize 'Date : 2007-10-11 (11 oct 2007) 'Purpose : strip doc and xls attachments from ' mails to reduce mailbox size ' Save them to a specified folder and ' put a notification in the mail where ' the file was saved to. Public Sub TestAttachmentRule() Const lngNoAttchmt_c As Long = 0 Dim ns As Outlook.NameSpace Dim mFldr As Outlook.MAPIFolder Dim itm As Object Dim mlItm As Outlook.MailItem Set ns = Outlook.Application.Session Set mFldr = ns.GetDefaultFolder(olFolderInbox) For Each itm In mFldr.Items If itm.Class = olMail Then Set mlItm = itm If mlItm.Attachments.Count <> lngNoAttchmt_c Then SaveAttachmentRule mlItm, ".doc", ".xls" End If End If Next MsgBox "Doc and Xls files are extracted from" & vbCrLf & _ "the emails in inbox folder.", vbInformation End Sub Public Sub SaveAttachmentRule(myItem As Outlook.MailItem, ParamArray _ PreferredFileExts() As Variant) 'Place to save the attachments Const strRootFolder_c As String = "C:\Data\Appendices\" Const strStockMsg_c As String = "The file was saved to: " Const strHTMLPTag_c As String = "<p>" Const lngPFLwrBnd As Long = 0 Const lngIncrement_c As Long = 1 Dim lngIneligibleFiles As Long Dim att As Outlook.Attachment Dim lngAttchmnetCnt As Long Dim strFilePath As String Dim lngPFUprBnd As Long Dim lngPFIndex As Long Dim strFileName As String 'index of attachment in mailmessage Dim lngItmAtt As Long lngPFUprBnd = UBound(PreferredFileExts) lngAttchmnetCnt = CountFiles(strRootFolder_c) 'Loop through each attachment: lngItmAtt = lngIncrement_c 'start with number one Do Until myItem.Attachments.Count = lngIneligibleFiles Set att = myItem.Attachments(lngItmAtt) 'Check if file is preferred, if it is, extract file from message and 'save and write extra info to message. strFileName = att.FileName For lngPFIndex = lngPFLwrBnd To lngPFUprBnd If LCase$(PreferredFileExts(lngPFIndex)) = _ LCase$(VBA.Right$(strFileName, _ VBA.Len(PreferredFileExts(lngPFIndex)))) Then Exit For End If Next If lngPFIndex <= lngPFUprBnd Then 'Increment Attachment Count: lngAttchmnetCnt = lngAttchmnetCnt + lngIncrement_c 'Build file-name for to be saved attachment: strFilePath = strRootFolder_c & BuildFileName(lngAttchmnetCnt, _ myItem, att) 'Save attachment to pre-determined folder using standard naming 'convention. att.SaveAsFile strFilePath 'Check for html mail or not: If myItem.BodyFormat = olFormatHTML Then myItem.HTMLBody = myItem.HTMLBody & strHTMLPTag_c & _ strStockMsg_c & strFilePath & strHTMLPTag_c Else myItem.Body = myItem.Body & vbCrLf & strStockMsg_c & _ strFilePath & vbNewLine End If att.Delete Else lngIneligibleFiles = lngIneligibleFiles + lngIncrement_c lngItmAtt = lngItmAtt + lngIncrement_c End If Loop If Not myItem.Saved Then myItem.Save End If End Sub Private Function CountFiles(strPath As String) As Integer 'Counts the no of files in a directory Dim FSO As Object Dim fldr As Object Set FSO = CreateObject("Scripting.FileSystemObject") Set fldr = FSO.GetFolder(strPath) CountFiles = fldr.Files.Count Set fldr = Nothing Set FSO = Nothing End Function Private Function BuildFileName(ByRef number As Long, ByRef mlItem As _ Outlook.MailItem, ByRef attchmnt As Outlook.Attachment, _ Optional dateFormat As String = "m_d_yyyy-H-MM-SS") As String 'Builds file name to preferred format. Can be changed to personal 'prefernce. Const strInfoDlmtr_c As String = " - " Const lngMxFlNmLen_c As Long = 255 BuildFileName = VBA.Left$(number & strInfoDlmtr_c & _ Format$(mlItem.ReceivedTime, dateFormat) & strInfoDlmtr_c & _ mlItem.SenderName & strInfoDlmtr_c & attchmnt.FileName, lngMxFlNmLen_c) End Function Private Sub Application_NewMailEx(ByVal EntryIDCollection As String) '*************************************************************************** 'Paste in ThisOutlookSession '*************************************************************************** SaveAttachmentRule Application.Session.GetItemFromID(EntryIDCollection) End Sub

How to use:

  1. In Outlook, press Alt-F11 to launch VBE (Visual Basic Editor).
  2. From insert menu, insert a standard module.
  3. Copy and paste above code into module (except Application_NewMailEx sub).
  4. In ThisOutlookSession Module paste Application_NewMailEx.
  5. From Debug Menu, compile.
  6. Save.
 

Test the code:

  1. From Outlook press Alt-F8 to run TestAttachmentRule.
 

Sample File:

No Attachment 

Approved by Oorang


This entry has been viewed 386 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2014 VBA Express