Download attachment and rename with subject line

**ali84pk** · 12-18-2010, 08:03 AM

Dear Gurus

I need urgent help, I have below macro to download attachment from email. But I need little amendment. I want to rename every attachment (in every email) with its subject line. My every email in outlook has only one attachment. I can't figure out how to do this trick.

Thanks in Advance

I am using this code to download all attachments

Sub Download_contracts(MyMail As MailItem)
Dim strID As String
Dim objNS As Outlook.NameSpace
Dim objMail As Outlook.MailItem
Dim objAtt As Outlook.Attachment
Dim c As Integer
Dim save_name As String
'Place path to sav to on next line. Note that you must include the
'final backslash
Const save_path As String = "D:\My Documents\Muhammad contracting\Contracts\"

strID = MyMail.entryID
Set objNS = Application.GetNamespace("MAPI")
Set objMail = objNS.GetItemFromID(strID)

If objMail.Attachments.Count > 0 Then
For c = 1 To objMail.Attachments.Count
Set objAtt = objMail.Attachments(c)
save_name = Left(objAtt.FileName, Len(objAtt.FileName) - 4)
'save_name = save_name & Format(objMail.ReceivedTime, "_mm-dd-yyyy_hhmm")
save_name = save_name & Right(objAtt.FileName, 4)
objAtt.SaveAsFile save_path & save_name

Next
End If

Set objAtt = Nothing
Set objMail = Nothing
Set objNS = Nothing
End Sub

**mrice** · 12-18-2010, 08:34 AM

Try

save_name = objMail.Subject

**ali84pk** · 12-18-2010, 09:58 AM

Dear Mrice

Thanks for quick reply :-) it worked perfectly.

Thanks a lot.

**DonkeyOte** · 12-18-2010, 10:13 AM

@ali84pk - glad you have a resolution - going forward please be sure to familiarise yourself with the Forum Rules re: Code Tags, Titles etc...

**nika81** · 04-25-2012, 01:33 PM

Originally Posted by mrice

Try

save_name = objMail.Subject

Hello,
So where does this fit in the code above?

**ali84pk** · 04-25-2012, 03:32 PM

Originally Posted by nika81

Hello,
So where does this fit in the code above?

Sub Download_attachments_Sent_by_me2me(MyMail As MailItem) 
Dim strID As String
Dim objNS As outlook.NameSpace
Dim objMail As outlook.MailItem
Dim objAtt As outlook.Attachment
Dim c As Integer
Dim save_name As String

'Place path to sav to on next line. Note that you must include the
'final backslash
Const save_path As String = "C:\Documents and Settings\AE1036\Desktop\Outlook attachments\"

strID = MyMail.EntryID
Set objNS = Application.GetNamespace("MAPI")
Set objMail = objNS.GetItemFromID(strID)

If objMail.Attachments.Count > 0 Then
For c = 1 To objMail.Attachments.Count
Set objAtt = objMail.Attachments(c)
save_name = Left(objAtt.filename, Len(objAtt.filename) - 4)
'save_name = save_name & Format(objMail.ReceivedTime, "_mm-dd-yyyy_hhmm")
save_name = save_name & Right(objAtt.filename, 4)


subject_name = objMail.Subject 'get subject
correct_sub = Replace(subject_name, ":", "") ' remove bad characters
objAtt.SaveAsFile save_path & correct_sub & ".pdf" ' save file on PATH with CORRECT SUB



Next
End If

Set objAtt = Nothing
Set objMail = Nothing
Set objNS = Nothing
End Sub