Download attachments from group of selected emails and rename

[n8isgr8]

Hi,

I'm looking to implement a macro that will download all the attachments from an outlook folder to a folder on my computer and then rename those attachments as the subject line of the email. Also I receive two attachments - one starts with bdoe and the other with sqr_bdoe. I only want to save the file that begins with bdoe.

Thanks!

[gmayor]

What is the subject of the message? What is the file format of the attachment in question? What happens if you have two messages with the same subject?

[n8isgr8]

What is the subject of the message? What is the file format of the attachment in question? What happens if you have two messages with the same subject?

There will be multiple emails with multiple subjects.
File format for both is csv
There should never be two emails with the same subject because they are system generated emails where I enter the subject line - I just cant change the name of the export file

Thanks!

[gmayor]

The reason I asked about subjects was to ensure that they did not contain illegal filename characters that would cause a crash if you tried to save the attachment with such a subject name. However it is easily handled.

The following, which is largely similar to code I have posted before will do what you ask, and it will also not overwrite an existing file of the same name.

The code calls a progress indicator. You can either remove references to that indicator from the macro or you can download it from http://www.gmayor.com/Forum/frmProgress.zip (http://www.gmayor.com/Forum/frmProgress.zip)and import the userform the zip contains into the Outlook project.


Option Explicit

Sub ProcessSelectedMessage()
'An Outlook macro by Graham Mayor
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveAttachments olMsg
lbl_Exit:
Exit Sub
End Sub

Sub ProcessFolder()
'An Outlook macro by Graham Mayor
Dim olNS As Outlook.NameSpace
Dim olMailFolder As Outlook.MAPIFolder
Dim olItems As Outlook.Items
Dim olMailItem As Outlook.MailItem
Dim oFrm As New frmProgress
Dim PortionDone As Double
Dim i As Long

On Error GoTo err_Handler
Set olNS = GetNamespace("MAPI")
Set olMailFolder = olNS.PickFolder
Set olItems = olMailFolder.Items
oFrm.Show vbModeless
i = 0
For Each olMailItem In olItems
i = i + 1
PortionDone = i / olItems.Count
oFrm.lblProgress.Width = oFrm.fmeProgress.Width * PortionDone
SaveAttachments olMailItem
DoEvents
Next olMailItem
err_Handler:
Unload oFrm
Set oFrm = Nothing
Set olNS = Nothing
Set olMailFolder = Nothing
Set olItems = Nothing
Set olMailItem = Nothing
lbl_Exit:
Exit Sub
End Sub


Private Sub SaveAttachments(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 28 Oct 2017
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
Const strSaveFldr As String = "C:\Path\Attachments\" 'Change as required, folder will be created if not present
'However the root drive must be present.
CreateFolders strSaveFldr
On Error GoTo lbl_Exit
If olItem.Attachments.Count > 0 Then
For j = 1 To olItem.Attachments.Count
Set olAttach = olItem.Attachments(j)
If olAttach.fileName Like "bdoe*.csv" Then
strFname = olItem.Subject & ".csv"
strExt = "csv"
strFname = CleanFileName(strFname, strExt)
strFname = FileNameUnique(strSaveFldr, strFname, strExt)
olAttach.SaveAsFile strSaveFldr & strFname
'olAttach.Delete 'delete the attachment
End If
Next j
olItem.Save
End If
lbl_Exit:
Set olAttach = Nothing
Set olItem = Nothing
Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
strFilename As String, _
strExtension As String) As String
'An Outlook macro by Graham Mayor
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFilename) - (Len(strExtension) + 1)
strFilename = Left(strFilename, lngName)
Do While FileExists(strPath & strFilename & Chr(46) & strExtension) = True
strFilename = Left(strFilename, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFilename & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(fldr) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function

Private Function CleanFileName(strFilename As String, strExtension As String) As String
'Graham Mayor
'A function to ensure there are no illegal filename
'characters in a string to be used as a filename
'strFilename is the filename to check
'strExtension is the extension of the file
Dim arrInvalid() As String
Dim vfName As Variant
Dim lng_Name As Long
Dim lng_Ext As Long
Dim lngIndex As Long
'Ensure there is no period included with the extension
strExtension = Replace(strExtension, Chr(46), "")
'Record the length of the extension
lng_Ext = Len(strExtension)

'Remove the path from the filename if present
If InStr(1, strFilename, Chr(92)) > 0 Then
vfName = Split(strFilename, Chr(92))
CleanFileName = vfName(UBound(vfName))
Else
CleanFileName = strFilename
End If

'Remove the extension from the filename if present
If Right(CleanFileName, lng_Ext + 1) = "." & strExtension Then
CleanFileName = Left(CleanFileName, InStrRev(CleanFileName, Chr(46)) - 1)
End If

'Define illegal characters (by ASCII CharNum)
arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
'Add the extension to the filename
CleanFileName = CleanFileName & Chr(46) & strExtension
'Remove any illegal filename characters
For lngIndex = 0 To UBound(arrInvalid)
CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lngIndex)), Chr(95))
Next lngIndex
lbl_Exit:
Exit Function
End Function