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 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