Add "Save attachment as subject" into script

[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