Consulting

Results 1 to 14 of 14

Thread: VBA Help - Add "Save attachment as subject" into script

  1. #1

    VBA Help - Add "Save attachment as subject" into script

    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

  2. #2
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    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

  4. #4
    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.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    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))))

  6. #6
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

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

  8. #8
    [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

  9. #9
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  10. #10
    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

  11. #11
    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?
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  12. #12
    Thank You very much Graham - it works now

  13. #13
    VBAX Newbie
    Joined
    Sep 2019
    Posts
    2
    Location
    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
    Last edited by Rasputin; 09-03-2019 at 09:47 PM.

  14. #14
    VBAX Newbie
    Joined
    Sep 2019
    Posts
    2
    Location
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •