Solved: Renaming word file based on first line/paragraph of text

[nerix]

Hello,
I have a bunch of *.doc files and need to rename them according to the first paragraph in each file, while document formatting stays untouched. I use Word 2007.

I've found a macro in another thread and it renames files, but removes all document formatting:
Sub EachYadda()
Dim oSection As Section
Dim r As range
Dim TempDoc As Document
Dim FirstPara As String

For Each oSection In ActiveDocument.Sections
Set r = oSection.Range
r.End = r.End - 1
Set TempDoc = Documents.Add
With TempDoc
.Range = r
FirstPara = r.Paragraphs(1).Range.Text
FirstPara = Left(FirstPara, Len(FirstPara) - 1)
.SaveAs Filename:= FirstPara & ".doc"
.Close
End With
Set r = Nothing
Set tempDoc = Nothing
Next
End Sub

I'm a complete newbie with VBA and I'm not sure which is better - to edit this code, or write it from beginning.

Any help would be greatly appreciated.

[fumei]

Try something like:
Option Explicit

Sub FirstPara()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
Dim FirstPara As String
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
FirstPara = .Paragraphs(1).Range.Text
FirstPara = Left(FirstPara, Len(FirstPara) - 1)
.SaveAs FileName:=FirstPara & ".doc"
.Close
End With
Set wdDoc = Nothing
strFile = Dir()
Wend
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
The function GetFolder gets the folder to work with; the rest of the code opens each .doc file in that folder; gets the text of the first paragraph and saves each file with that name.

Your code takes the text of each Section of one document. Why.

[Doug Robbins]

The following code will ask for the folder and then rename all of the Word files in the folder that you select:
Sub GetRenameFiles()
Dim fd As FileDialog
Dim strFolder As String
Dim strFile As String
Dim aDoc As Document
Dim rngNewName As Range
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select the folder that contains the files."
If .Show = -1 Then
strFolder = .SelectedItems(1) & "\"
Else
MsgBox "You did not select a folder."
Exit Sub
End If
End With
strFile = Dir$(strFolder & "*.doc*")
While strFile <> ""
Set aDoc = Documents.Open(strFolder & strFile)
Set rngNewName = aDoc.Paragraphs(1).Range
rngNewName.MoveEnd wdCharacter, -1
aDoc.SaveAs2 rngNewName.Text
aDoc.Close
strFile = Dir$()
Wend
End Sub

[fumei]

A good example of how VBA can get to the same end using (slightly) different routes.

[nerix]

Thank you, guys!

Fumei, your macro works perfectly.

Doug Robbins, your macro throws run-time error '438', "Object doesn't support this property or method" after choosing the folder with files. Debugger links to the row aDoc.SaveAs2 rngNewName.Text

Also, maybe it would be possible to add feature in to the macro, which omits forbidden characters in the file name (" * / : < > ? \ |)? Now all paragraphs with question marks throw run-time error.

[Doug Robbins]

Replace

aDoc.SaveAs2 rngNewName.Text

with

aDoc.SaveAs rngNewName.Text

The SaveAs2 command was added in Word 2010 so it will not work with earlier versions.

To deal with the ?, use before the aDoc>SaveAs command:

rngNewName.Text = Replace(rngNewName.Text, "?", "")

You would need to include a similar line of code to deal with any other forbidden characters.