Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\Scripts")

Set objWord = CreateObject("Word.Application")

For Each strFile in objFolder.Files
    arrNames = Split(strFile.Name, ".")
    If arrNames(1) = "rtf" Then
        Set objDoc = objWord.Documents.Open(strFile.Path)
        Set objRange = objDoc.Range(0,3)
        strNewName = "C:\Scripts\" & objRange.Text & ".rtf"
        objDoc.Close
        Wscript.Sleep 3000
        objFSO.MoveFile strFile.Path, strNewName
    End If
Next

objWord.Quit