Removing & Saving Attachments from Mails

[safwanjamil]

Hi,

I was searching for a macro to strip off attachments from mails and came across some code by Charlize (KB id 953). Opps, I can't post the link...

While using this with Outlook 2003, I observered that all the messages with .doc or .xls attachments are getting stripped off instead of the ones selected. Also it does not give results with folders other than Inbox...

I do not have much idea about the VBA codes. Can anyone please help. Also wouldn't it be a great idea to get the file extensions (.doc,.xls, *.*) and the folder path to save attachments from users at runtime.

Thanks in advance for all your help

~Jamil

[Charlize]

This is the part for selecting the folder where you want to save the attachments.[VBA]Sub Choose_Directory_Or_Create_One()
Dim mypath As Variant
mypath = BrowseForFolder("C:\")
If mypath = False Then
MsgBox "No directory chosen !", vbExclamation
Else
MsgBox "Save to : " & mypath, vbInformation
End If
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function[/VBA]Charlize

[safwanjamil]

Hi,

Thanks for the quick response. Let me try to integrate this the prev. code and see. Am new to VBA...but still I would like to give that a try myself...

[Charlize]

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.
[vba]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 Function[/vba]Charlize

ps.: There isn't a check if you select a directory or not.

[safwanjamil]

Hi,

I tried with this code but came across an issue:
For every attachment, it asks me to select the path where I want to save file so I moved the "Call Choose_Directory_Or_Create_One" out of the SaveAttachmentRule... above the FOR loop (for checking each attachment). This issue was resolved.

I'm yet to explore if I can use activeexplorer.selection.count and a loop to strip off only the attachments selected and not all the attachments from the mail forlder

Many thanks.

[Charlize]

Example :[VBA]Sub Example_Using_Selection()
'The message you want to process
Dim MyMessage As Outlook.MailItem
'a number
Dim myItem As Long
'if selection isn't present, don't do a thing
'you could build an extra check if the class
'of the selected item is a message
If ActiveExplorer.Selection.Count < 1 Then
MsgBox "Select at least one mailmessage", vbInformation
Exit Sub
End If
For myItem = 1 To ActiveExplorer.Selection.Count
Set MyMessage = ActiveExplorer.Selection.item(myItem)
If MyMessage.Attachments.Count > 0 Then
MsgBox "Message has attachments", vbInformation
Else
MsgBox "Message has no attachments", vbInformation
End If
'go to next selected mail
Next myItem
End Sub[/VBA]Charlize

[safwanjamil]

Sorry again for being late ;-). Was out and had no access.

Charlize, many thanks. This piece of code is indeed 'COOL'. I tried integrating with the previous codes and it gives wonderful results. Lemme clean up the mess I have created in the VBA (my outlook) and I'll post the complete code.

Thanks