How can I automatically rename a whole batch of word files?

[Guest]

I recently had to recover a great number of files, but unfortunately although
all the information is in the word documents, the titles are all file01,
file02 etc. I was wondering if there exists a tool that would allow me to
rename the files based on the first few words of the document? This would
save us many hours of boring detailed work.

 

[Greg Maxey]

With some code tips from Jay Freedman, Doug Robbins and JGM, I was able to
put together the following. Put all of your files in a single folder (I
used "C:\Batch Folder" and run the macro:

Public Sub BatchReNameFiles()

Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim NewName As String
Dim OldName As String
Dim oRng As Range
Dim i As Integer
Dim j As Integer

'Specify folder where files are located
PathToUse = "C:\Batch Folder\"
'Count files in folder
OldName = Dir$(PathToUse & "*.doc")
While OldName <> ""
i = i + 1
OldName = Dir$()
Wend
'Rename files
j = 0
myFile = Dir$(PathToUse & "*.doc")
Do While myFile <> "" And j < i
j = j + 1
Set myDoc = Documents.Open(FileName:=PathToUse & myFile, Visible:=False)
With myDoc
OldName = .FullName
Set oRng = .Words(1)
oRng.End = .Words(min(9, .Words.Count - 1)).End
NewName = Trim(oRng.Text) & ".doc"
NewName = Replace(NewName, "\", "")
NewName = Replace(NewName, ":", "")
NewName = Replace(NewName, """", "")
NewName = Replace(NewName, vbCr, "")
NewName = Replace(NewName, vbTab, "")
.Close SaveChanges:=wdSaveChanges
End With
Name OldName As PathToUse & NewName
myFile = Dir$()
Loop

End Sub
Private Function min(a As Long, b As Long)
min = -((a < b) * a + (a >= b) * b)
End Function