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.