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