Outlook VBA script to save file with subject as filename

[Xyseven]

Good day. New member here

Long story short:
I would like a script that grabs the attachments from a incoming mails and saves them in a specified folder with the subject as the filename.

The bigger picture:
I regularly recieve mails with attached pdf files. The pdf filename is always called "Vedlegg" ("attachement" in norwegian) and the subject field is always "ARBEIDSORDRE 589492/2012 ,VH35682 ,FORHÅNDSVIS" except for the numbers being different each time. I work in a car workshop and these pdf's are work-orders containing a description of what to repair on the different cars. Thus the numbers will be different on each mail, but I want them to be automatically stored with the subject field as the filename.

Also, I am aware that "/" can not be used in filenames. So I would like something that inserts a space instead and also maybe deletes the first and last word "ARBEIDSORDRE" and "FORHÅNDSVIS" as those are of no interest when I later want to search for it.

I have fund and tried several scripts that did similar to this, but none that does it excactly the way I'd want to.

Kind Regards
-Xy-

[westconn1]

is this what you need? where subj is you email subject

fname = Replace(Mid(subj, 13, Len(fn) - 25), "/", " ")
msgbox fname

[Xyseven]

Thank you for the quick reply, but I wouldn't know where to put that line as I have no knowledge of VBA or any programming at all. My job is with automobilenetworking and hardware



I am using this today (which does almost what I want):

Sub SaveAllAttachments(objitem As MailItem)

Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double

strLocation = "K:\Ny mappe struktur\Servicemarked\Volkswagen og Audi verksted\Gjennomganger - Teksteark\Jack\"

On Error GoTo ExitSub
If objitem.Class = olMail Then
Set objAttachments = objitem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
GoTo 100
End If
For dblLoop = 1 To dblCount
strID = " from " & Format(Date, "mm-dd-yy")
strName = objAttachments.Item(dblLoop).Filename 'Get attachment name
strExt = Right$(strName, 4) 'Store file Extension
strName = Left$(strName, Len(strName) - 4) 'Remove file Extension
strName = strName & strID & strExt 'Reattach Extension
strName = strLocation & strName
objAttachments.Item(dblLoop).SaveAsFile strName
Next dblLoop
'objitem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing

End Sub

[westconn1]

For dblLoop = 1 To dblCount
strID = " from " & Format(Date, "mm-dd-yy")
strName = objAttachments.Item(dblLoop).Filename 'Get attachment name
strExt = Right$(strName, 4) 'Store file Extension
strName = Left$(strName, Len(strName) - 4) 'Remove file Extension
strName = strName & strID & strExt 'Reattach Extension
strName = strLocation & strName
objAttachments.Item(dblLoop).SaveAsFile strName
Next dblLoop

try change to

For dblLoop = 1 To dblCount
  strName = strLocation & Replace(Mid(objitem.subject, 13, Len(fn) - 25), "/", " ") & ".pdf"
  objAttachments.Item(dblLoop).SaveAsFile strName
Next dblLoop

[Xyseven]

Tried it, but it seemed to do just the same as the other one (couldn't see any difference).

My new code now looks like this:


Sub SaveAllAttachments(objitem As MailItem)

Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double

strLocation = "K:\Ny mappe struktur\Servicemarked\Volkswagen og Audi verksted\Gjennomganger - Teksteark\Jack\"

On Error GoTo ExitSub
If objitem.Class = olMail Then
Set objAttachments = objitem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
GoTo 100
End If
For dblLoop = 1 To dblCount
strName = strLocation & Replace(Mid(objitem.Subject, 13, Len(fn) - 25), "/", " ") & ".pdf"
objAttachments.Item(dblLoop).SaveAsFile strName
Next dblLoop
'objitem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing

End Sub

[westconn1]

but it seemed to do just the same as the other one (couldn't see any difference).

post sample of the outputted filenames
and objitem.subject

[Xyseven]

On closer examination it doesn't seem like the attachment is stored at all now. My bad!

What do you mean with objitem.subject?

[westconn1]

Sub SaveAllAttachments(objitem As MailItem)

i would assume that objitem should have a subject property
if not you have to return the subject from some property of objitem, else you can not build the filename from it

msgbox objitem.subject

as i do not have outlook installed i can not easily check the properties of mail ltems

[Xyseven]

Should I write this line in somewhere you mean: msgbox objitem.subject ? (sorry but my coding skills are zero)

[westconn1]

Should I write this line in somewhere you mean

yes on a line on its own, anywhere in the procedure, near the top is probably best
should present a box with the subject of the email

[Xyseven]

I pasted that line in near the top and now I do get a popup with the subject and an "OK" button on it. Still doesn't autosave the file with subject as name though. My new code looks like this:




Sub SaveAllAttachments(objitem As MailItem)

MsgBox objitem.Subject
Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double

strLocation = "K:\Ny mappe struktur\Servicemarked\Volkswagen og Audi verksted\Gjennomganger - Teksteark\Jack\"

On Error GoTo ExitSub
If objitem.Class = olMail Then
Set objAttachments = objitem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
GoTo 100
End If
For dblLoop = 1 To dblCount
strID = " from " & Format(Date, "mm-dd-yy")
strName = objAttachments.Item(dblLoop).Filename 'Get attachment name
strExt = Right$(strName, 4) 'Store file Extension
strName = Left$(strName, Len(strName) - 4) 'Remove file Extension
strName = strName & strID & strExt 'Reattach Extension
strName = strLocation & strName
objAttachments.Item(dblLoop).SaveAsFile strName
Next dblLoop
'objitem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing

End Sub

[westconn1]

Still doesn't autosave the file with subject as name though. My new code looks like this:

that is because you are not using the subject when you create the strname to save the file as

[Xyseven]

Would you know how the code should look like to do that?
Thanks for taking your time this far, this is all new to me

[westconn1]

Would you know how the code should look like to do that?

see post #4, that should be the correct code, put a msgbox strname before thesavAs line, to make sure the file path\name is exactly how you want it

[Xyseven]

I didnt find a line called "savAs" so I put it over what seemed similar (at the very top), but this didn't do it either. My new code now looks like this:

NB: I'm aware that I most likely has missunderstood what you ment here?!


MsgBox strName
Sub SaveAllAttachments(objitem As MailItem)

Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double

strLocation = "K:\Ny mappe struktur\Servicemarked\Volkswagen og Audi verksted\Gjennomganger - Teksteark\Jack\"

On Error GoTo ExitSub
If objitem.Class = olMail Then
Set objAttachments = objitem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
GoTo 100
End If
For dblLoop = 1 To dblCount
strName = strLocation & Replace(Mid(objitem.Subject, 13, Len(fn) - 25), "/", " ") & ".pdf"
objAttachments.Item(dblLoop).SaveAsFile strName
Next dblLoop
'objitem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing

End Sub

[westconn1]

My new code now looks like this:

does it work? what happens? it looks like it should be correct

I didnt find a line called "savAs"

i meant like

strName = strLocation & Replace(Mid(objitem.Subject, 13, Len(fn) - 25), "/", " ") & ".pdf"
msgbox strname ' just to see it the path\filename lloks like it is correct
objAttachments.Item(dblLoop).SaveAsFile strName

your code would be better if you avoided the goto 100 as it is not needed
for dblloop =1 to objAttachments.Count will skip if count is any value < 1
if a message has more than 1 attachment each will overwrite the previous

if any error occurs, it will go to your error handler, but without telling you, so you can not know which parts of the code have not been processed

[Xyseven]

Good morning and sorry for not elaborating, I forgot my cofee )

No, it didn't do anything at all - not even saving the attachment. If I understood you correctly above I have now pasted in and removed the different lines and ended up with this code (but it doesn't do anything - not even saving the attachment):



MsgBox strName
Sub SaveAllAttachments(objitem As MailItem)

Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double

strLocation = "K:\Ny mappe struktur\Servicemarked\Volkswagen og Audi verksted\Gjennomganger - Teksteark\Jack\"

On Error GoTo ExitSub
If objitem.Class = olMail Then
Set objAttachments = objitem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
End If
For dblLoop = 1 To dblCount
strName = strLocation & Replace(Mid(objitem.Subject, 13, Len(fn) - 25), "/", " ") & ".pdf"
MsgBox strName ' just to see it the path\filename lloks like it is correct

objAttachments.Item(dblLoop).SaveAsFile strName
Next dblLoop
'objitem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing

End Sub

[westconn1]

but it doesn't do anything - not even saving the attachment):

so you get no mesagebox?

i am not sure with outlook if the attachments collection starts at 1, just in case try changing the loop to
for dblloop = 0 to dblcount - 1

i can not test the code to see why it fails, as i do not have outlook installed, but if the messagebox does not show the loop is never running

[Xyseven]

No messagebox and no saving the attachement even when I changed the line you said. However, when I looked more closely at the VBA script in alt+f11 I noticed that the MsgBox strName didn't seem to be a part of the code... It had some kind of line separating it from the rest of the code, and when I moved it under the line "Sub SaveAllAttachments(objitem As MailItem)" and sent myself a mail with attachement I get this error:

---------------------------
Microsoft Visual Basic
---------------------------
Compile error:

Duplicate declaration in current scope
---------------------------
OK Help
---------------------------


And it highlights this line in yellow:
Sub SaveAllAttachments(objitem As MailItem)



My current code looks like this:



Sub SaveAllAttachments(objitem As MailItem)
MsgBox strName

Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double

strLocation = "K:\Ny mappe struktur\Servicemarked\Volkswagen og Audi verksted\Gjennomganger - Teksteark\Jack\"

On Error GoTo ExitSub
If objitem.Class = olMail Then
Set objAttachments = objitem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
End If
For dblLoop = 1 To dblCount
strName = strLocation & Replace(Mid(objitem.Subject, 13, Len(fn) - 25), "/", " ") & ".pdf"
MsgBox strName ' just to see it the path\filename lloks like it is correct

objAttachments.Item(dblLoop).SaveAsFile strName
Next dblLoop
'objitem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing

End Sub

[westconn1]

I get this error:

that is because you used the variable strname, above where it is dimensioned, it should be below all the dim lines

as strname has no value at that point you would only get an empty messagebox
but at leas you can tell the code runs to that point

you need to put breakpoints in the code, or step through the code line by line to find what is actually happening
put a breakpoint at the line (click in the left margin, a red dot should appear)
For dblLoop = 1 To dblCount
the code should then break when it gets to that line, will appear highlighted in yellow
you can then step through the code on line at a time (F8), to see where it goes

[Xyseven]

Thanks for your time and effort here! I moved some lines around but I still get the grey line under MsgBox strName thingy. I managed to click on some red dots in there, and tried to run the code with and without those red dots, but no change. Now the code doesn't seem to do nothing, not even saving the attachement.

My new code looks like this:


Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double
MsgBox strName
_________________________________________________________ (strange grey line)
Sub SaveAllAttachments(objitem As MailItem)
strLocation = "K:\Ny mappe struktur\Servicemarked\Volkswagen og Audi verksted\Gjennomganger - Teksteark\Jack\"
On Error GoTo ExitSub
If objitem.Class = olMail Then
Set objAttachments = objitem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
End If
For dblLoop = 1 To dblCount
strName = strLocation & Replace(Mid(objitem.Subject, 13, Len(fn) - 25), "/", " ") & ".pdf"
MsgBox strName ' just to see it the path\filename lloks like it is correct
objAttachments.Item(dblLoop).SaveAsFile strName
Next dblLoop
'objitem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing
End Sub

[westconn1]

all you code must be within the procedure

_________________________________________________________ (strange grey line)
Sub SaveAllAttachments(objitem As MailItem)

Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double
MsgBox strName '  should be empty messagebox as strname is empty at this point

strLocation = "K:\Ny mappe struktur\Servicemarked\Volkswagen og Audi verksted\Gjennomganger - Teksteark\Jack\"
On Error GoTo ExitSub
If objitem.Class = olMail Then
Set objAttachments = objitem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
End If   ' put breakpoint on next line, then step through code to see if it enters loop
For dblLoop = 1 To dblCount
strName = strLocation & Replace(Mid(objitem.Subject, 13, Len(fn) - 25), "/", " ") & ".pdf"
MsgBox strName ' just to see it the path\filename lloks like it is correct
objAttachments.Item(dblLoop).SaveAsFile strName
Next dblLoop
'objitem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing
End Sub

[Xyseven]

There I got the empty pop-up back! )
However it doesn't save the attachement. And I'm not sure what you ment with "put breakpoint on next line, then step through code to see if it enters loop" (yes I do feel like an idiot when it comes to this)

[westconn1]

And I'm not sure what you ment with "put breakpoint on next line

see post #20

[Xyseven]

Ok, tried my best here. Clicked in the margin in front of each line and tried to run the script again. It takes me to the script editor and I'm able to run the script line by line with F8. It seems to go through the lines one by one, but it skips those lines I've highlighted in red down here:



Sub SaveAllAttachments(objitem As MailItem)

Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double
MsgBox strName ' should be empty messagebox as strname is empty at this point

strLocation = "K:\Ny mappe struktur\Servicemarked\Volkswagen og Audi verksted\Gjennomganger - Teksteark\Jack\"
On Error GoTo ExitSub
If objitem.Class = olMail Then
Set objAttachments = objitem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
End If ' put breakpoint on next line, then step through code to see if it enters loop
For dblLoop = 1 To dblCount
strName = strLocation & Replace(Mid(objitem.Subject, 13, Len(fn) - 25), "/", " ") & ".pdf"
MsgBox strName ' just to see it the path\filename lloks like it is correct
objAttachments.Item(dblLoop).SaveAsFile strName
Next dblLoop
'objitem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing
End Sub

[westconn1]

despite the fact that you did not highlight the line
strName = strLocation & Replace(Mid(objitem.Subject, 13, Len(fn) - 25), "/", " ") & ".pdf"
i assume that was skipped too

now try changing the loop to start at zero instead of 1, see post #18
in fact, how about rereading all the previous posts?

you do not need a break point on every line, once the code stops you can step through line by line, until you press the run button (or F5)

[Xyseven]

Sorry for being a complete newbie here )

The line "strName = strLocation & Replace(Mid(objitem.Subject, 13, Len(fn) - 25), "/", " ") & ".pdf"" gets highlighted and doesn't seem to be skipped. Then I read through and tried to change the lines in the order of the posts and ended up with this code. The empty pop-up is therem but no attachements are saved:



Sub SaveAllAttachments(objitem As MailItem)
Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double
MsgBox strName ' should be empty messagebox as strname is empty at this point
strLocation = "K:\Ny mappe struktur\Servicemarked\Volkswagen og Audi verksted\Gjennomganger - Teksteark\Jack\"
On Error GoTo ExitSub
If objitem.Class = olMail Then
Set objAttachments = objitem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
End If ' put breakpoint on next line, then step through code to see if it enters loop
For dblLoop = 0 To dblCount - 1
strName = strLocation & Replace(Mid(objitem.Subject, 13, Len(fn) - 25), "/", " ") & ".pdf"
MsgBox strName ' just to see it the path\filename lloks like it is correct
objAttachments.Item(dblLoop).SaveAsFile strName
Next dblLoop
'objitem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing
End Sub

[westconn1]

i think i have seen an error from when i copied the original code i tested, the error has been carried through all modifications

try to change like

strName = strLocation & Replace(Mid(objitem.Subject, 13, Len(objitem.subject) - 25), "/", " ") & ".pdf"

the error may have just caused VBA to terminate, without warning, though that is unusual

[Xyseven]

Anyone else have any good tips to me on this script? Thank you for great help this far though westconn1 - even though I don't know anything about what a code is you managed to make me understand most of what you said )

[Xyseven]

*shameless bump*

[westconn1]

where have you got to now?
i am not sure why you are still having a problem, as there is enough information for it to work with only minor changes

[Xyseven]

Then someone would kindly have to explain that to me, because I can't understand anything from this. I have no knowledge in anything related to computer coding. If this was an issue with a vehicle I'd nail it though )

[westconn1]

Then someone

looks like you are stuck with me, as you have had no other responses, many of the people who used to do outlook coding, in this forum, appear to have moved on to elsewhere

to help any further i need to know what is going on in your code, which i can not test, did you try changing the line as in post #28
when you step through the code, at which line does the macro stop?
when you write code you use indenting, as in a small example in post #4
when you post here use code tags and the formatting will display correctly, this makes it so much easier for anyone reading your code

If this was an issue with a vehicle I'd nail it though

if you can help me diagnose problems with late model CR diesels i would consider it a good trade

[Xyseven]

Hey there. Good new years to you! I've been busy over the holidays so please excuse my late reply. Regarding my script I've given up on it, but maybe I could ask for more details around your CR diesel problem out of curiosity. Could you try to describe what you are experiencing to me, and please include the car make/model and year?

[westconn1]

Could you try to describe what you are experiencing to me, and please include the car make/model and year?

unfortunately they are many, varied and ongoing, some i fix, others i run out of guesses