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