Macro saves email as word doc- but I want to add to the file name that it uses

[sadsmileyfac]

I sourced a useful bit of VBA that saves the contents of an email as a Word doc. It uses the subject line of the email as the file name of the Word doc.

However, I'm looking to customize this a bit.

Each email is like a standard form. There's one bit of text I'd like to grab from each and include it at the end of the file name. Do you think this would be possible?

So for an example, if the email subject was NEW JOB APPLICATION, the file name would be NEW JOB APPLICATION.doc. Say the content always included a bit of text that read 'Name: JOHN SMITH', I'd like to grab everything that came after 'Name: ' and include that in the file name, so in our example, it would be NEW JOB APPLICATION JOHN SMITH.doc.

This is the code that I've been using:


Sub SaveEmail()
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim aItem As Object
Dim dtDate As Date
Dim sName As String


Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection


For Each aItem In Selection
aItem.BodyFormat = olFormatRichText

'If you want to convert all messages to RTF, uncomment this line.
'Otherwise, the message format is not changed.
'aItem.Save

sName = aItem.Subject
ReplaceCharsForFileName sName, "_"




aItem.SaveAs "c:\FOLDER\" & sName & ".doc", olRTF

Next aItem


Set currentExplorer = Nothing
Set Selection = Nothing

End Sub

[gmayor]

Assuming that ReplaceCharsForFileName removes illegal filename characters from the proposed name, then the following should do the job. Note that if the filename already exists in the folder it will be overwritten.


ub SaveEmail()
'Graham Mayor - http://www.gmayor.com - Last updated - 18 Jul 2017
Dim currentExplorer As Explorer
Dim olInsp As Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim Selection As Selection
Dim aItem As Object
Dim dtDate As Date
Dim sName As String
Dim bFound As Boolean
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each aItem In Selection
With aItem
.BodyFormat = olFormatRichText
'If you want to convert all messages to RTF, uncomment this line.
'Otherwise, the message format is not changed.
'aItem.Save
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
.Display
With oRng.Find
Do While .Execute(findText:="Name:")
oRng.collapse 0
oRng.End = oRng.Paragraphs(1).Range.End - 1
bFound = True
Exit Do
Loop
End With
sName = .Subject
If bFound = True Then
sName = sName & Chr(32) & Trim(oRng.Text)
End If
ReplaceCharsForFileName sName, "_"
.SaveAs "c:\FOLDER\" & sName & ".doc", olRTF
.Close 0
End With
Next aItem
Set currentExplorer = Nothing
Set Selection = Nothing
Set olInsp = Nothing
Set oRng = Nothing
Set wdDoc = Nothing
End Sub

[sadsmileyfac]

Thanks so much for your quick work on this! I think I'm close to getting it working- I get an error at the saving part.

If the search is unsuccessful in finding findText in the content, the file saves successfully (obviously without the suffix added to the file name).

However, it seems that if the search for findText is positive, it fails at the file save (Run-time error '-214746259 (80004005)').

Do you have any ideas as to what I've done?

[gmayor]

The answer was based on your description of the issue. Without an actual message to test with, it's all a bit hit and miss.
Comment out the
.SaveAs "c:\FOLDER\" & sName & ".doc", olRTF line and replace it with
Debug.Print sName
and check in the immediate window (CTRL+G) what sName is actually producing.

[sadsmileyfac]

Thank you- that's a bit more illuminating. It looks like it finds findText (red font below), then copies it AND everything that's coming after it (blue font).

So the file name for the below content take the subject and then adds '_interviewer__john_smith_interview_start__14-jul-2017_13_14'... etc.


Application type: Job
Application Classification: First Time
Name: Jane Smith
Interviewer: John Smith
Interview Start: 14-Jul-2017 13:14
Interview End: 14-Jul-2017 13:30
Interview Weather Condition: Dry
Interview Time: 13:16
Picture:
Attachment 1

General Comments:
Etc

[gmayor]

In that case the lines are not separate paragraphs but separated by line breaks. Replace

oRng.End = oRng.Paragraphs(1).Range.End - 1
with

oRng.MoveEndUntil Chr(11)

[sadsmileyfac]

In that case the lines are not separate paragraphs but separated by line breaks. Replace

oRng.End = oRng.Paragraphs(1).Range.End - 1
with

oRng.MoveEndUntil Chr(11)

You probably hear this all the time, but you're a fantastic help! Thank you so much for solving this problem!

[sadsmileyfac]

I have a follow up question if I may- am I restricted to only saving in .doc format or is it able to be saved as a modern .docx?

[gmayor]

The short answer is no. Outlook cannot save the message in docx format, but with a little lateral thinking you could get Word to do that e.g. having created the RTF version, run Word, open the document, save it as DOCX format, close the document then delete the RTF version:


Sub SaveEmail()
'Graham Mayor - http://www.gmayor.com - Last updated - 19 Jul 2017
Dim currentExplorer As Explorer
Dim olInsp As Inspector
Dim wdApp As Object
Dim oDoc As Object
Dim wdDoc As Object
Dim oRng As Object
Dim Selection As Selection
Dim aItem As Object
Dim dtDate As Date
Dim sName As String
Dim bFound As Boolean
Dim bStarted As Boolean
Dim bBackup As Boolean
Const strFolder As String = "C:\Folder\"

Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each aItem In Selection
With aItem
.BodyFormat = olFormatRichText
'If you want to convert all messages to RTF, uncomment this line.
'Otherwise, the message format is not changed.
'aItem.Save
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
.Display
With oRng.Find
Do While .Execute(findText:="Name:")
oRng.collapse 0
oRng.MoveEndUntil Chr(11)
bFound = True
Exit Do
Loop
End With
sName = .Subject
If bFound = True Then
sName = sName & Chr(32) & Trim(oRng.Text)
End If
ReplaceCharsForFileName sName, "_"
.SaveAs strFolder & sName & ".doc", olRTF
.Close 0
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
bStarted = True
Err.Clear
End If
On Error GoTo 0
wdApp.Visible = True
Set oDoc = wdApp.documents.Open(strFolder & sName & ".doc")
bBackup = wdApp.Options.CreateBackup
wdApp.Options.CreateBackup = False
oDoc.SaveAs2 _
fileName:=strFolder & sName & ".docx", _
FileFormat:=12, _
CompatibilityMode:=Val(Application.Version)
wdApp.Options.CreateBackup = bBackup
oDoc.Close
Kill strFolder & sName & ".doc"
End With
Next aItem
If bStarted Then wdApp.Quit
Set currentExplorer = Nothing
Set Selection = Nothing
Set olInsp = Nothing
Set oRng = Nothing
Set wdApp = Nothing
Set oDoc = Nothing
Set wdDoc = Nothing
End Sub

[sadsmileyfac]

Outstanding work again! Thanks for your patience and help with this.

My machine isn't too fast so it's a slower method but it results in much lower file-sizes which makes a difference when you have thousands of documents. This is great.

[gmayor]

If you have thousands of documents, the chance of getting duplicated names is much more likely. You should add a function to ensure that doesn't happen - see below. As I haven't seen your code for removing illegal filename characters, I have added one that I use also.

Note that if Word is not running when you run the macro, the code has to start Word and that adds significantly to the processing time.


Option Explicit

Sub SaveEmail()
'Graham Mayor - http://www.gmayor.com - Last updated - 19 Jul 2017
Dim currentExplorer As Explorer
Dim olInsp As Inspector
Dim wdApp As Object
Dim oDoc As Object
Dim wdDoc As Object
Dim oRng As Object
Dim Selection As Selection
Dim aItem As Object
Dim dtDate As Date
Dim sName As String
Dim bFound As Boolean
Dim bStarted As Boolean
Dim bBackup As Boolean
Dim strFName As String
Const strFolder As String = "C:\Folder\"

Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each aItem In Selection
With aItem
.BodyFormat = olFormatRichText
'If you want to convert all messages to RTF, uncomment this line.
'Otherwise, the message format is not changed.
'aItem.Save
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
.Display
With oRng.Find
Do While .Execute(findText:="Name:")
oRng.collapse 0
oRng.MoveEndUntil Chr(11)
bFound = True
Exit Do
Loop
End With
sName = .Subject
If bFound = True Then
sName = sName & Chr(32) & Trim(oRng.Text)
End If
sName = CleanFileNameChars(sName)
.SaveAs strFolder & sName & ".doc", olRTF
.Close 0
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
bStarted = True
Err.Clear
End If
On Error GoTo 0
wdApp.Visible = True
Set oDoc = wdApp.documents.Open(strFolder & sName & ".doc")
bBackup = wdApp.Options.CreateBackup
wdApp.Options.CreateBackup = False
strFName = sName & ".docx"
strFName = FileNameUnique(strFolder, strFName, "docx")
oDoc.SaveAs2 _
fileName:=strFolder & strFName, _
FileFormat:=12, _
CompatibilityMode:=Val(Application.Version)
wdApp.Options.CreateBackup = bBackup
oDoc.Close
Kill strFolder & sName & ".doc"
End With
Next aItem
If bStarted Then wdApp.Quit
Set currentExplorer = Nothing
Set Selection = Nothing
Set olInsp = Nothing
Set oRng = Nothing
Set wdApp = Nothing
Set oDoc = Nothing
Set wdDoc = Nothing
End Sub

Private Function FileNameUnique(strPath As String, _
strFilename As String, _
strExtension As String) As String
'Graham Mayor - http://www.gmayor.com - Last updated - 19 Jul 2017
Dim lngF As Long
Dim lngName As Long
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
lngF = 1
lngName = Len(strFilename) - (Len(strExtension) + 1)
strFilename = Left(strFilename, lngName)
Do While fso.FileExists(strPath & strFilename & Chr(46) & strExtension) = True
strFilename = Left(strFilename, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFilename & Chr(46) & strExtension
lbl_Exit:
Set fso = Nothing
Exit Function
End Function

Private Function CleanFileNameChars(strText As String) As String
'Graham Mayor - http://www.gmayor.com - Last updated - 19 Jul 2017
'A function to ensure there are no illegal filename
'characters in a string to be used as a filename
'strText is the filename to check
Dim arrInvalid() As String
Dim lngIndex As Long
CleanFileNameChars = strText
'Define illegal characters (by ASCII CharNum)
arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
'Remove any illegal filename characters
For lngIndex = 0 To UBound(arrInvalid)
CleanFileNameChars = Replace(CleanFileNameChars, Chr(arrInvalid(lngIndex)), Chr(95))
Next lngIndex
lbl_Exit:
Exit Function
End Function

[sadsmileyfac]

I've been trying this out with some older messages from a few years ago and found an odd behavior. While the macro works mostly, in that it creates and saves a .doc, it fails correctly run the findText part so nothing is added to the end of the filename.

My guess is that it has something to do with the format of the older messages. The older messages are content-type: multipart/mixed, whereas the modern ones are content-Type: text/html. Does this sound like something that could stop that part of the macro from working right?

Edit: I got some progress by setting .BodyFormat = olFormatHTML but it means it no longer saves the attachments within the doc. Still progress!

[gmayor]

How are the old messages formatted in terms of content?

[sadsmileyfac]

They appear to be exactly the same as the modern ones (just text) with the only observable difference is that they used to come with files attached whereas the modern ones come with HTML links to files.

[gmayor]

Hmmm. It appears the section

With oRng.Find
Do While .Execute(findText:="Name:")
oRng.collapse 0
oRng.MoveEndUntil Chr(11)
bFound = True
Exit Do
Loop
End With
is not finding the name. You could try declaring the variable

Dim strList As String: strList = Chr(11) & "," & Chr(13)at the top of the macro and change the line

oRng.MoveEndUntil Chr(11)to

oRng.MoveEndUntil strListbut without seeing an actual message, this is just fishing in the dark.

[sadsmileyfac]

Hmmm. It appears the section

With oRng.Find
Do While .Execute(findText:="Name:")
oRng.collapse 0
oRng.MoveEndUntil Chr(11)
bFound = True
Exit Do
Loop
End With
is not finding the name. You could try declaring the variable

Dim strList As String: strList = Chr(11) & "," & Chr(13)at the top of the macro and change the line

oRng.MoveEndUntil Chr(11)to

oRng.MoveEndUntil strListbut without seeing an actual message, this is just fishing in the dark.

Despite that, you got a bite! You fixed it again! Thank you!