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