For Word documents, you might use something like the following Word macro:
Sub RenameDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String
Dim strDocNm As String, strNewNm As String
Dim strNames As String, wdDoc As Document, i As Long
Const StrNoChr As String = """“”*.,/\:?|" & vbTab
strDocNm = ActiveDocument.FullName: strNames = ","
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
If strFolder & "\" & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
For i = 1 To .Paragraphs.Count
With .Paragraphs(i).Range
If Len(Trim(.Text)) > 1 Then
strNewNm = Trim(Split(.Sentences.First, vbCr)(0))
Exit For
End If
End With
Next
For i = 1 To Len(StrNoChr)
strNewNm = Replace(strNewNm, Mid(StrNoChr, i, 1), "_")
Next
If InStr(strNames, "," & strNewNm & ",") > 0 Then
strNewNm = strNewNm & " (" & Split(strNames, "," & strNewNm)(UBound(Split(strNames, "," & strNewNm))) + 1 & ")"
End If
strNames = strNames & strNewNm & ","
strNewNm = strNewNm & "." & Split(.Name, ".")(1)
.Close SaveChanges:=False
End With
Name strFolder & "\" & strDocNm As strFolder & "\" & strNewNm
End If
strFile = Dir()
Wend
Set wdDoc = 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
You could use something similar for PowerPoint, looping through slides and shapes till you find one with text content. You could also use something similar with Excel by looking for the first cell that doesn't have a formula.
Now that I've given you the code for Word, you should study other threads on this board for hints on how to adapt it to work with PowerPoint and Excel.