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