The following assumes that all the files in the selected folder are processed
It assumes that the macro text to be found is in the body of the document and not the VBA project
It assumes that there is only one such macro in the document
It assumes that the renamed file does not already exist.
I would suggest you work with copies of the files rather than the originals.
Option Explicit
Sub RenMacroDocs()
Dim strFolder As String
Dim strFilename As String
Dim strNewName As String
Dim strSavePath As String
Dim strExt As String
Dim oDoc As Document
Dim oRng As Range
Dim FSO As Object
strFolder = BrowseForFolder
strSavePath = strFolder & "\Renamed\"
Set FSO = CreateObject("scripting.filesystemobject")
If Not FSO.FolderExists(strSavePath) Then
FSO.CreateFolder strSavePath
End If
strFilename = Dir$(strFolder & "*.doc")
While Len(strFilename) <> 0
strNewName = ""
WordBasic.DisableAutoMacros 1
strExt = Mid(strFilename, InStrRev(strFilename, Chr(46)))
Set oDoc = Documents.Open(strFolder & strFilename)
Set oRng = oDoc.Range
With oRng.Find
Do While .Execute(FindText:="Sub *>", MatchWildcards:=True)
oRng.Start = oRng.Start + 4
strNewName = oRng.Text
Exit Do
Loop
End With
oDoc.Close 0
If Not strNewName = "" Then
Name strFolder & strFilename As strSavePath & strNewName & Mid(strFilename, InStrRev(strFilename, Chr(46)))
End If
strFilename = Dir$()
WordBasic.DisableAutoMacros 0
Wend
lbl_Exit:
Set FSO = Nothing
Set oDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub
Private Function BrowseForFolder(Optional strTitle As String) As String
'Graham Mayor
'strTitle is the title of the dialog box
Dim fDialog As FileDialog
On Error GoTo err_Handler
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.TITLE = strTitle
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then GoTo err_Handler:
BrowseForFolder = fDialog.SelectedItems.Item(1) & Chr(92)
End With
lbl_Exit:
Exit Function
err_Handler:
BrowseForFolder = vbNullString
Resume lbl_Exit
End Function