Add "Save attachment as subject" into script

[sdrussell]

Hiya I have a working script which I found online and have adapted which moves an attachment from an email in my inbox or a subfolder into a folder on my desktop. I would like to rename each attachment with the subject line of the email the attachment is contained in but am not sure how to do it. Any help would be gratefully received

Option Explicit
Const folderPath = “C:\Documents and Settings\kollol\My Documents\emailTest\”

Sub CompanyChange()
    On Error Resume Next
    Dim ns As NameSpace
    Set ns = GetNamespace(“MAPI”)
    Dim Inbox As MAPIFolder
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Dim searchFolder As String
    searchFolder = InputBox(“What is your subfolder name?”)
    Dim subFolder As MAPIFolder
    Dim Item As Object
    Dim Attach As Attachment
    Dim FileName As String
    Dim i As Integer
    If searchFolder <> “inbox” Then
            Set subFolder = Inbox.Folders(searchFolder)
            i = 0
            If subFolder.Items.Count = 0 Then
                MsgBox “There are no messages in the Inbox.”, vbInformation, “Nothing Found”
                Exit Sub
            End If
            For Each Item In subFolder.Items
                For Each Attach In Item.Attachments
                    Attach.SaveAsFile (folderPath & Attach.FileName)
                    i = i + 1
                Next Attach
            Next Item
            ‘ to search specific type of file:
            ‘ For Each Item In Inbox.Items
                ‘ For Each Atmt In Item.Attachments
                    ‘ If Right(Atmt.FileName, 3) = “xls” Then
                        ‘ FileName = “C:\Email Attachments\” & Atmt.FileName
                        ‘ Atmt.SaveAsFile FileName
                        ‘ i = i + 1
                 ‘ End If
             ‘ Next Atmt
        ‘ Next Item
    Else
        i = 0
        If Inbox.Items.Count = 0 Then
            MsgBox “There are no messages in the Inbox.”, vbInformation, “Nothing Found”
            Exit Sub
        End If
        On Error Resume Next
        For Each Item In Inbox.Items
            For Each Attach In Item.Attachments
                FileName = folderPath & Attach.FileName
                Attach.SaveAsFile FileName
                i = i + 1
            Next Attach
        Next Item
    End If
End Sub

[gmayor]

In theory

FileName = folderPath & Item.Subject & Right(Attach.FileName, InStrRev(Attach.FileName, Chr(46)))

However there are some things to consider when approaching this issue.
What do you want to do about illegal filename characters in the subject.
What do you want to do if there is more than one attachment.
What do you want to do if the filename already exists in the target folder.

See http://www.vbaexpress.com/forum/show...ll-attachments

[sdrussell]

Many thanks for the reply Graham . I can confirm that there is only one attachment on the emails I want to transfer and also the subject is always unique. I am quite new to creating VBA scripts so your help is appreciated!! would you be able to let me know where about in the script I would need to add the lines you have posted above? Thanks

[gmayor]

I have not attempted to debug your code but you have

FileName = folderPath & Attach.FileName

and

Attach.SaveAsFile (folderPath & Attach.FileName)

you should have instead

FileName = folderPath & Item.Subject & Right(Attach.FileName, InStrRev(Attach.FileName, Chr(46)))

and

Attach.SaveAsFile (folderPath & Item.Subject & Right(Attach.FileName, InStrRev(Attach.FileName, Chr(46))))

The subject may be unique, but this will not work as it stands if the subject contains illegal filename characters.

[sdrussell]

Thanks Graham for all your help. I seem to be getting a syntax error on the line Attach.SaveAsFile (folderPath & Item.Subject & Right(Attach.FileName, InStrRev(Attach.FileName, Chr(46))))

[gmayor]

I knew it would have been quicker to check your code, which, even without that issue, doesn't run.

Having done so it is not clear what you are trying to do exactly, but the following will save all the attachments from a selected folder of messages using the subject as the filename and correcting for illegal filename characters. I have not allowed for duplicated filenames. Any filename that exists will be overwritten:

Option Explicit

Sub CompanyChange()
    ' Graham Mayor - http://www.gmayor.com - Last updated - 05 Jul 2017
    Dim olNS As NameSpace
    Dim objItem As Object
    Dim olAttach As Attachment
    Dim strFileName As String
    Dim strExt As String
    Dim olFolder As Folder
    Const strPath = "C:\Documents and Settings\kollol\My Documents\emailTest\"
    On Error Resume Next
    Set olNS = GetNamespace("MAPI")
    Set olFolder = olNS.PickFolder
    If olFolder.Items.Count = 0 Then
        If Err.Number = 91 Then Exit Sub
        MsgBox "There are no messages in the selected folder", vbInformation, _
               "Nothing Found"""
        Exit Sub
    End If
    On Error GoTo 0
    For Each objItem In olFolder.Items
        For Each olAttach In objItem.Attachments
            strExt = Right(olAttach.FileName, InStrRev(olAttach.FileName, Chr(46)))
            strFileName = objItem.Subject
            strFileName = CleanFileName(strFileName)
            strFileName = strPath & strFileName & strExt
            olAttach.SaveAsFile strFileName
        Next olAttach
    Next objItem
    MsgBox "Processing complete!"
    lbl_Exit:
    Set objItem = Nothing
    Set olAttach = Nothing
    Set olNS = Nothing
    Set olFolder = Nothing
    Exit Sub
End Sub

Private Function CleanFileName(strFileName As String) As String
    ' Graham Mayor - http://www.gmayor.com - Last updated - 05 Jul 2017
    ' A function to ensure there are no illegal filename characters in a string to be used as a filename
    Dim arrInvalid() As String
    Dim vfName As Variant
    Dim lng_Name As Long
    Dim lng_Ext As Long
    Dim lngIndex As Long
    CleanFileName = strFileName
    ' 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
    ' 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

[sdrussell]

Thanks Graham your a superstar!! Thanks for all your help it works perfectly!!

[adrian123]

GRAHAM - is there any way to run that script without asking or selecting folder?
I need to Save & Rename Attachment with Subject but without asking for folder - in outlook I have set the rule which will pick up mails and from selected mails I have to save and rename files based on subject.
Thank you in advance

[gmayor]

If you want the process to work as a script from a rule, then you need to lose the loop. The following will rename the attachments with the listed extensions to match the subject and save them in the named folder. Note that this will overwrite any attachment of the same name already in that folder. If that is what you require then see the following. I have included a test macro to test the process with a selected message. Save_As_Subject can be run from the rule.

Sub Test()
    Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    Save_As_Subject olMsg
    lbl_Exit:
    Exit Sub
End Sub

Sub Save_As_Subject(olItem As MailItem)
    ' Graham Mayor - http://www.gmayor.com - Last updated - 13 Jan 2018
    Dim olAttach As Attachment
    Dim strFileName As String
    Dim strExt As String
    Const strPath = "C:\Path\Attachments\"    'the path to store the files
    For Each olAttach In olItem.Attachments
        strExt = Mid(olAttach.fileName, InStrRev(olAttach.fileName, Chr(46)))
        Select Case LCase(strExt)
            Case Is = ".docx", ".dotx", ".pdf", ".xlsx", ".zip"  'the wanted extensions
                strFileName = olItem.Subject
                strFileName = CleanFileName(strFileName)
                strFileName = strPath & strFileName & strExt
                olAttach.SaveAsFile strFileName
            Case Else
        End Select
    Next olAttach
    lbl_Exit:
    Set olItem = Nothing
    Set olAttach = Nothing
    Exit Sub
End Sub

Private Function CleanFileName(strFileName As String) As String
    ' Graham Mayor - http://www.gmayor.com - Last updated - 05 Jul 2017
    ' A function to ensure there are no illegal filename characters in a string to be used as a filename
    Dim arrInvalid() As String
    Dim vfName As Variant
    Dim lng_Name As Long
    Dim lng_Ext As Long
    Dim lngIndex As Long
    CleanFileName = strFileName
    ' 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
    ' 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

[adrian123]

GRAHAM - Thank you for the script - unfortunatly If I am running your previous sctript with folder selection it is working fine. - If I am using the new one it does not do anything. I just modified the path to match my one. If I am running it there is no any message nothing, no saved files at all - in all cases attached files are .pdf. In rule manager I can correctly pick up the Scipt so I can see the name of it. Do you have any idea why it is not saving any fiels?

Thank you in advance

Sub Save_As_Subject(olItem As MailItem) 
    Dim olAttach As Attachment
    Dim strFileName As String
    Dim strExt As String
    Const strPath = "C:\Path\Attachments\" 'the path to store the files     
    For Each olAttach In olItem.Attachments
        strExt = Mid(olAttach.FileName, InStrRev(olAttach.FileName, Chr(46)))
        Select Case LCase(strExt)
        Case Is = ".docx", ".dotx", ".pdf", ".xlsx", ".zip" 'the wanted extensions
            strFileName = olItem.Subject
            strFileName = CleanFileName(strFileName)
            strFileName = strPath & strFileName & strExt
            olAttach.SaveAsFile strFileName
        Case Else
        End Select
    Next olAttach
    lbl_Exit:
    Set olItem = Nothing
    Set olAttach = Nothing
    Exit Sub
End Sub
 
Private Function CleanFileName(strFileName As String) As String    
    Dim arrInvalid() As String
    Dim vfName As Variant
    Dim lng_Name As Long
    Dim lng_Ext As Long
    Dim lngIndex As Long
    CleanFileName = strFileName
     '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
     '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

[gmayor]

I have just tested it and it works fine from the test macro I posted - though you can abbreviate the line

Case Is = ".docx", ".dotx", ".pdf", ".xlsx", ".zip" 'the wanted extensions

to

Case Is = ".pdf"

if you are only interested in PDF format files.

If it is not working for you, is your rule identifying the messages with the attachments?

[adrian123]

Thank You very much Graham - it works now

[Rasputin]

I have been using this script and so many thanks for creating it .

One improvement need help with is saving the attachments from a group of Subfolder in Outlook and saving them in indivudual folders on Hard Drive.

Any help i appreciated.
Thanks

Ok think got i working

Sub SaveAttachments()
    ' Graham Mayor -  Last updated - 05 Jul 2017
    Dim olNS As NameSpace
    Dim objItem As Object
    Dim olAttach As Attachment
    Dim strFileName As String
    Dim strExt As String
    Dim olFolder As Folder
    Dim olFolderSub As Folder
    Dim FSO As Object
    Dim HDFolder As String
    ' Set path to Hard Drive Location a Needed
    Const strPath = "C:\MainFOLDER\"
    MsgBox "Depending on how many Subfolders and Attachments this could take some time, please be patient", vbInformation, "Patience"""
    Set FSO = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set olNS = GetNamespace("MAPI")
    ' Set the Outlook Folder that contains the Subfolders SubFolder_Holder needs to be set as per your Outlook Folders
    Set olFolder = olNS.GetDefaultFolder(olFolderInbox).Folders("Subfolder_Holder")
    For Each olFolderSub In olFolder.Folders
        If olFolderSub.Items.Count = 0 Then
             If Err.Number = 91 Then Exit Sub
             MsgBox "There are no messages in the selected folder", vbInformation, "Nothing Found"""
             Exit Sub
        End If
        On Error GoTo 0
        For Each objItem In olFolderSub.Items
             For Each olAttach In objItem.Attachments
                HDFolder = strPath & olFolderSub.Name
                If Not FSO.FolderExists(HDFolder) Then
                    FSO.CreateFolder (HDFolder)
                End If
                ' Adjust this for different Do Types, Can Use CASE if needed
                strExt = ".pdf"
                strFileName = objItem.Subject
                strFileName = CleanFileName1(strFileName)
                strFileName = HDFolder & "\" & strFileName & strExt
                olAttach.SaveAsFile strFileName
            Next olAttach
        Next objItem
    Next
    MsgBox "Processing complete!"
    lbl_Exit:
    Set objItem = Nothing
    Set olAttach = Nothing
    Set olNS = Nothing
    Set olFolder = Nothing
    Set FSO = Nothing
    Exit Sub
End Sub

[Rasputin]

All Good i think i got it working.
Atered Code above to this

Dim olNS As NameSpace
Dim objItem As Object
Dim olAttach As Attachment
Dim strFileName As String
Dim strExt As String
Dim olFolder As Folder
Dim olFolderSub As Folder
Dim FSO As Object
Dim HDFolder As String
Const strPath = "C:\Users\Robert.Auld\OneDrive - Shell\completed assessments"
MsgBox "Depending on how many Subfolders and Attachments this could take some time, please be patient", vbInformation, "Patience"""
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set olNS = GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(olFolderInbox).Folders("Assessments Scanned")
' Set olFolder = olNS.Folders("Assessments Scanned")
For Each olFolderSub In olFolder.Folders
    If olFolderSub.Items.Count = 0 Then
        If Err.Number = 91 Then Exit Sub
        MsgBox "There are no messages in the selected folder", vbInformation, "Nothing Found"""
        Exit Sub
    End If
    On Error GoTo 0
    For Each objItem In olFolderSub.Items
        For Each olAttach In objItem.Attachments
            HDFolder = strPath & olFolderSub.Name
            If Not FSO.FolderExists(HDFolder) Then
                 FSO.CreateFolder (HDFolder)
            End If
            strExt = ".pdf"
            strFileName = objItem.Subject
            strFileName = CleanFileName1(strFileName)
            strFileName = HDFolder & "" & strFileName & strExt
            olAttach.SaveAsFile strFileName
        Next olAttach
    Next objItem
    Next
    MsgBox "Processing complete!"
    lbl_Exit:
    Set objItem = Nothing
    Set olAttach = Nothing
    Set olNS = Nothing
    Set olFolder = Nothing
    Set FSO = Nothing
    Exit Sub
End Sub

[scarroll]

My extracted file name seems to be combining the email subject and a portion of the file name rather than replacing with the email subject. Any ideas?

Email Subject: Master Hospital Dashboard: Family Pet
File Name: Master Hospital Dashboard
Extracted File Name: Master Hospital Dashboard: Family Petter Hospital Dashboard

[gmayor]

There is a lot of code in this thread, and you have not specified which you have used, however if you use my code from the 13th January 2018, it does not do what you claim except that the colon (an illegal filename character) is replaced by an underscore.

[spica58]

Hey Graham! I'll be using your script daily, thank you so much I wanted to know if there's a way to make it work with more than one selected email? I've tested it by selecting multiple emails in a folder and it only saves the attachment from the first one.

[EricB_TX]

Graham,

This has been incredibly useful for me. Quick question, I have done some looking around and trying to figure out if its possible to add in either the sent date or received date either before or after the subject. If not, this has still been a huge time saver for me.

[gmayor]

Locate the line

strFileName = olItem.Subject

and change it to

strFileName = olItem.Subject & Format(olItem.ReceivedTime, " yyyymmdd")