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 strList

but 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 strList

but without seeing an actual message, this is just fishing in the dark.

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