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

[QUOTE=gmayor;364241]

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