Save outlook attachments and rename/append files with identifier from subject line

Hi All,

I'm a newbie to VBA and was hoping I can get some assistance from the masters..I currently have about a 2000+ e-mails with attachments to where I want to save those files and rename them with the subject line of the e-mail to my hard drive. I've been able to accomplish that with the below macro for the .XLS files (which I found on this forum), however I am unable to do the same activity with the .pdf files. The PDF files have all the same names (Report.1). Could that be an issue? Would appreciate any help! Apologies if I posted anything wrong.

Please Login or Register  to view this content.

Thank you Alpha Frog. I just checked the Email subjects and yes, they contain colons...Here is an example of a subject line, but subject lines are not uniform in naming- ERF Site Name: NL-xxx: Project ID: Uxxx.2C.NL0xxx.1B.OEM.6601Dxx-ID.WA.GK1615.01132013 Callout: hK803741641C12 This is 1 of 1 ERFs for this callout

Since the attachments all have the same name, how can I modify the code so that I can download and rename them to be in sequential order (Report_1, Report_2, Report_3....)?

Alpha Frog, I might be missing something, but it seems that the files are being overwritten as they download to the folder. Out of some +1000 attachments, i've only been able to save about 9 attachments.

Formula:

Please Login or Register  to view this content.

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 = "C:\Users\michael.dia\Documents\OLAttachments\"

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)
i = i + 1
save_name = "Report_" & i & ".pdf"
objAtt.SaveAsFile save_path & save_name


Next
End If

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

Formula:

Please Login or Register  to view this content.

Sweet! That did the trick, but the files are all corrupted and I can't open the PDF's. I'll try again..