Option Explicit
Option Compare Text
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)
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
Dim lngItmAtt As Long
lngPFUprBnd = UBound(PreferredFileExts)
lngAttchmnetCnt = CountFiles(strRootFolder_c)
lngItmAtt = lngIncrement_c
Do Until myItem.Attachments.Count = lngIneligibleFiles
Set att = myItem.Attachments(lngItmAtt)
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
lngAttchmnetCnt = lngAttchmnetCnt + lngIncrement_c
strFilePath = strRootFolder_c & BuildFileName(lngAttchmnetCnt, _
myItem, att)
att.SaveAsFile strFilePath
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
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
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)
SaveAttachmentRule Application.Session.GetItemFromID(EntryIDCollection)
End Sub
|