This is the whole coding. It's a little bit difficult to explain what you have to change to get everything to work. Watch the comments with ***. Those are the places where I have changed something. Take notice that this isn't bulletproof (yet). Have to test this. Also it will still be for all the mails of the specified folder you select. If you only want to do this on a bunch of mails, use activeexplorer.selection.count and a loop.
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)
'Test is a subfolder from inbox
'*** When you don't select a folder, there will be an
' error
'***
On Error GoTo errorfound
'*** Here you select the folder you want to process
Set mFldr = ns.Session.PickFolder
'***
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
errorfound:
Select Case Err.number
Case 91
MsgBox "Error no. : " & Err.number & vbCrLf & _
"No folder selected ...", vbCritical
Case Else
MsgBox "Error no. : " & Err.number & vbCrLf & _
Err.Description, vbCritical
End Select
On Error GoTo 0
End Sub
Public Sub SaveAttachmentRule(myItem As Outlook.MailItem, ParamArray _
PreferredFileExts() As Variant)
'Place to save the attachments
Dim 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
Call Choose_Directory_Or_Create_One
'*** mypath is declared public
' in the Choose_Directory_Or_Create_One routine
strRootFolder_c = mypath & "\"
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 FunctionCharlize
ps.: There isn't a check if you select a directory or not.