VBA script to auto download attachments and rename file according to subject line

[dvlkn]

Hi everyone

First time poster here. I am trying to edit this script to automatically download attachment(s) from certain emails (based on rules) and rename the attachment to what is in the subject line. The subject line typically says:
"Ticket # 1111111111 Order # 999999999" and I would like to return to only the "1111111111". The file type is usually .pdf if that matters.
By looking around, I only have the following code that will download the attachment and save it as it is.

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "path here"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub

This is what I have so far but it is not working obviously:

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim Subject As String
Dim Ticket As String
saveFolder = "path here"
For Each objAtt In itm.Attachments
Subject = itm.Subject
If InStr(1, Subject, "#") > 0 Then
'Trim beginning of subject
Subject = Mid(Subject, InStr(Subject, "#") + 1)
'Trim ending of subject
If InStr(Subject, " ") > 0 Then
Ticket = Left(Subject, InStr(Subject, " Order") - 1)
End If
End If
objAtt.SaveAsFile saveFolder & "\" & Invoice
Set objAtt = Nothing
Next
End Sub

 

[Diane Poremsky]

What part doesn't work?

you need to add the extension to the filename -

objAtt.SaveAsFile saveFolder & "\" & Ticket & ".pdf"

 

[dvlkn]

Thank you for your reply. I am not sure which part does not work. When I run the rule which runs the script, it says something like "Cannot save the file to folder xyz". Not having put the extension might be what is preventing it from saving the file. I will give your suggestion a try as soon as I get home! Thanks for your help!

 

[Diane Poremsky]

The folder you are saving to needs to exist. Also, don't forget to put the path in this line -
saveFolder = "path here"

 

[dvlkn]

Yes i did put the path, I just omitted it in this post to simplify. Sorry about that.
So I added the extension and it looks like it is running. However when I ran it on 5 emails, it resulted in only one PDF (there is one attachment per email) being saved without a name. So I am guessing my "parsing" for the ticket # is incorrect and it just overwrites itself continuously resulting in only one file with no name.
Is mid() and instr() the functions that I should use or is there a better way?

 

[Diane Poremsky]

Yes i did put the path, I just omitted it in this post to simplify. Sorry about that.

I assumed that is what you did, but wanted to double check.

I don't think the parsing is wrong, but that the macro isn't getting a new item or clearing the old item. You could try using Subject = "" before setting it and/or try setting itm = nothing at the end.

You can add debug.print subject and debug.print ticket to see if its using the right values. You can do the same for the instr fnctions to see if the expected values are correct. They'll be show in the immediate window - Ctrl+G to open.

Actually, you don't need to check the subject for blanks do you? Remove that if/end if pair.

 If itm.Attachments.Count > 0 Then 
     Subject = itm.Subject 
For Each objAtt In itm.Attachments 
If InStr(1, Subject, "#") > 0 Then 
      'Trim beginning of subject 
    Subject = Mid(Subject, InStr(Subject, "#") + 1) 
     'Trim ending of subject 
    Ticket = Left(Subject, InStr(Subject, " Order") - 1) 
End If 
    objAtt.SaveAsFile saveFolder & "\" & Ticket & ".pdf" 
Next 
Set objAtt = Nothing 
Set itm = Nothing

 

[Diane Poremsky]

It shouldn't make a difference, but you can also do all the subject/ticket stuff together then get the attachment

 If itm.Attachments.Count > 0 Then 
     Subject = itm.Subject 
 
If InStr(1, Subject, "#") > 0 Then 
      'Trim beginning of subject 
    Subject = Mid(Subject, InStr(Subject, "#") + 1) 
     'Trim ending of subject 
    If InStr(Subject, " ") > 0 Then 
        Ticket = Left(Subject, InStr(Subject, " Order") - 1) 
     End If 
End If 
For Each objAtt In itm.Attachments 
    objAtt.SaveAsFile saveFolder & "\" & Ticket & ".pdf" 
Next

And hope you only have 1 attachment.

 

[dvlkn]

Thank you for your help! I was able to fix my code shortly after I posted. Like you said, I do not need the script to check for subject for blanks after all. I can even omit the check for attachment since the "rule" that I run already pick up emails that has one
The completed code for the sake of sharing:

Dim objAtt As Outlook.Attachment 
Dim saveFolder As String 
Dim Subject As String 
Dim Ticket As String 
 
saveFolder = "C:\Test" 
     For Each objAtt In itm.Attachments 
Subject = itm.Subject 
 
'Trim beginning of subject 
Subject = Mid(Subject, InStr(Subject, "#") + 1) 
 
'Trim ending of subject 
Ticket = Left(Subject, InStr(Subject, " Order") - 1) 
 
objAtt.SaveAsFile saveFolder & "\" & Ticket & ".pdf" 
 
Set objAtt = Nothing 
Next 
 
End Sub

 

[Diane Poremsky]

So the blanks code was causing all the problems? I never would have guessed.

 

[dvlkn]

Hi Diane! Maybe you can help me out again. I am now receiving attachments but with nothing relevant in the subject line. The attachment name itself contains the ticket number that I need. So I figure I would have to re-direct the script to the attachment name itself and trim the excess information before it saves to folder. Can you tell me how do I go about doing that? And would it work if there are more than one attachment this time?

Looking through the "code dictionnary" I found attachment.Filename, is that something I should be using?

In short, I have an attachment that comes in as Ticket # 11111 Order # 12345 and I would like it to return to only 11111.

 

[Diane Poremsky]

Yes, use objAtt.filename - you'll strip it the same way - might be able to use the code above and change just one line:

saveFolder = "C:\Test"
For Each objAtt In itm.Attachments
Subject = objAtt.filename

 

[Bench]

Hi Diane!

Sorry to hijack this post but my problem is related to the solution that is kindly provided by Diane!
The code works in my situation! But an error message pops up when I try to open the file:/

The file I receive is an ".xlsx" format file and like dvlkn, I required to extract the unique identifier in the email and rename the file.

"Excel cannot open the file 'Jul-09.xlsx' because the file format or file extension is not valid. Verify that the file has not been corrupted and that the file extension matches the format of the file." *see picture

I tried to save it as '.xls' format instead, and the file manages to open but the contents are all corrupted.

Any clue what's going on?

(Btw, I administered this code to a few different types of emails I receive and all work well except this particular one)

Thank you for your help!

 

[Forum Admin]

Can you open the original file ok if you save it to the hard drive? The error means the extension does not match the file type so either the code is wrong or the attachment is corrupted.

 

[Bench]

Can you open the original file ok if you save it to the hard drive? The error means the extension does not match the file type so either the code is wrong or the attachment is corrupted.

Yup the original attachment opens up just fine...
its really odd

The file is not a protected/encrypted file either.

 

[ev8383]

Hello,
I've modified the code to work with multiple attachments (files are saved as 1111111111(1).pdf , 1111111111(2).pdf etc ). Is it possible to modify the code in such a way so that numeration is only applied if there is more than 1 attachment.

Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim Subject As String
Dim Ticket As String
saveFolder = "C:\Test"
     For Each objAtt In itm.Attachments
Subject = itm.Subject
'Trim beginning of subject
Subject = Mid(Subject, InStr(Subject, "#") + 1)
'Trim ending of subject
Ticket = Left(Subject, InStr(Subject, " Order") - 1)
objAtt.SaveAsFile saveFolder & "\" & Ticket & ".pdf"
Set objAtt = Nothing
Next
End Sub

Many thanks!!

 

[Michael Bauer]

Call the part that adds the number only if itm.attachments.count>1

 

[ev8383]

Call the part that adds the number only if itm.attachments.count>1

Thank for response. I've tried the following but don't seem to get it to work. Can you please check

Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim Subject As String
Dim Ticket As String
Dim i As Integer
saveFolder = "C:\Test"
Subject = itm.Subject

Subject = Mid(Subject, InStr(Subject, "#") + 1)

Ticket = Left(Subject, InStr(Subject, " Order") - 1)

If itm.attachments.count > 1 Then
        
i = 1
For Each objAtt In itm.Attachments
  objAtt.SaveAsFile saveFolder & "\" & Ticket & "(" & CStr(i) & ").pdf"
  i = i + 1
     Else
objAtt.SaveAsFile saveFolder & "\" & Ticket & ".pdf"

Next

End Sub

 

[Michael Bauer]

The For-Next block must be before the Else. It looks like this:

If ... Then
    'condition met
    For....
    Next
Else
    'condition not met
    .....
End If

 

[Frank M]

Diane, I've working on this for a couple of days and I need some help. I need to have Outlook sort the attachments based on a key part of the subject line into different folders in my pc. How can I make it happen? Thanks for your help!

 

[Diane Poremsky]

After you identify the message, you can use a case statement or an array to set the folder.
Select Case True
case instr(1,item.subject,"phrase") >0
saveFolder = "path"

case instr(1,item.subject,"phrase2") >0
saveFolder = "new path"
end select