VBA Help - 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/showthread.php?59889-Save-all-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. :banghead:

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!!:clap2:

[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 :bow: 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")