Sub RenameDocuments()
Application.ScreenUpdating = False
Dim strFldr As String, strDocNm As String, strFile As String, strNewNm As String, wdDoc As Document
Dim FSO As Object, objFile As Object
strDocNm = ActiveDocument.FullName
strFldr = GetFolder
If strFldr = "" Then Exit Sub
Set FSO = CreateObject("Scripting.FileSystemObject")
strFldr = strFldr & "\"
strFile = Dir(strFldr & "*.doc", vbNormal)
While strFile <> ""
  If strFldr & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFldr & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      strNewNm = .SelectContentControlsByTitle("TreatyStatement/OurReference1")(1).Range.Text _
          & "_" & .SelectContentControlsByTitle("TreatyStatement/OurReference2")(1).Range.Text _
          & "." & Split(.Name, ".")(UBound(Split(.Name, ".")))
      .Close SaveChanges:=False
    End With
    If FSO.FileExists(strFldr & strNewNm) Then
      ActiveDocument.Range.InsertAfter "Unable to create:" & Chr(11) & strFldr & strNewNm & Chr(11) & "File Exists" & vbCr
    Else
      Set objFile = FSO.GetFile(strFldr & strFile)
      objFile.Name = strNewNm
    End If
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing: Set objFile = Nothing: Set FSO = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function