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