Fair call...
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
'************************************************************************** *
'Paste in ThisOutlookSession
'************************************************************************** *
SaveAttachmentRule Application.Session.GetItemFromID(EntryIDCollection)
End Sub
Public Sub TestAttachmentRule()
Const lngNoAttchmt_c As Long = 0
Dim ns As NameSpace
Dim mFldr As MAPIFolder
Dim itm As Object
Dim mlItm As 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 MailItem, ParamArray PreferredFileExts() As Variant)
'Place to save the attachments
Const strRootFolder_c As String = "C:\attachments\"
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 att As Attachment
Dim lngIneligibleFiles As Long
Dim lngPFUprBnd As Long
Dim lngPFIndex As Long
Dim lngAttchmnetCnt As Long
Dim lngItmAtt As Long 'index of attachment in mailmessage
Dim strFilePath As String
Dim strFileName As String
If myItem.Size < 1500000 Then
Exit Sub
End If
' lngPFUprBnd = UBound(PreferredFileExts)
lngAttchmnetCnt = CountFiles(strRootFolder_c)
'Loop through each attachment:
lngItmAtt = lngIncrement_c 'start with number one
Do Until myItem.Attachments.Count = 0 '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 MailItem, ByRef att As 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 & att.FileName, lngMxFlNmLen_c)
End Function