Batch renaming of file name?

[Programmer_n]

I got around 500 word documents file stored with the name 'the macros1.doc', 'the macros2.doc', 'the macros3.doc' so on and so forth.

As it is VBA macros file the content of each file contains a code line Sub filename1(), Sub filename2 () for each file respectively.

Now a folder contains all those files sitting to be renamed, I need a VBA to open each file in folder and find the sub filename1() line and copy it and rename the file with that name and proceed on to do it for all the 500+ files with respective sub file name...

Is it possible? Please guide if you have handled such circumstance previously.

[gmayor]

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

[Programmer_n]

Thanks. It is right solution for my question.