Sub GetRenameFiles()
Dim oFD As FileDialog
Dim strFolder As String
Dim strFile As String
Dim oDoc As Document
Dim oRng As Range
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFD = Application.FileDialog(msoFileDialogFolderPicker)
With oFD
.Title = "Select the folder that contains the files."
If .Show = -1 Then
strFolder = .SelectedItems(1) & "\"
Else
MsgBox "You did not select a folder."
Exit Sub
End If
End With
strFile = Dir$(strFolder & "*.doc*")
While strFile <> ""
Set oDoc = Documents.Open(strFolder & strFile)
Set oRng = oDoc.Range
With oRng.Find
.Text = "Title"
If .Execute Then
oRng.MoveEndUntil Chr(13)
oRng.Start = oRng.Start + 7
End If
End With
If Not oFSO.FileExists(oDoc.Path & "\" & oRng.Text & Right(oDoc.Name, Len(oDoc.Name) - InStr(oDoc.Name, ".") + 1)) Then
oDoc.SaveAs2 oRng.Text
Else
oDoc.SaveAs2 oRng.Text & "-dup"
End If
oDoc.Close
strFile = Dir$()
Wend
End Sub