To batch-rename your files, try the following macro. It includes its own folder browser, so all you need to do is to point it to the folder concerned. Just make sure that the only files in that folder are the ones to be renamed. If they don't conform to the structure of your attachment, the macro will crash.
Code:
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
The macro also generates a report of any files it might not be able to rename because a file with the proposed new name already exists. You'll find that report in the document you run the macro from once it's finished processing.