Save file name as first line in word and then increment.

[authorleon]

Hello

I want to change this function please but I do not know how:


baseFile.SaveAs _
FileName:=saveFN & Format(iterNum, "0000") & ".prtl", _
FileFormat:=wdFormatText, _
AddToRecentFiles:=False

' close the modified file without saving
baseFile.Close SaveChanges:=wdDoNotSaveChanges

iterNum = iterNum + 1
Next para

Instead of incrementing the file name, I would like it to take the first line of text of the word doc as the file name and then the next line for the next file.

Example:

Word Doc:

Perter Pan: /Green Pants/
Captain Hook: /Hook/

Output file: Please note that the "/" and ":" has to be removed, maybe replaced with "-" or the file cannot be saved
Perter Pan: Green Pants
Captain Hook: Hook


Original Code:


Option Explicit

Sub EditVideoFile()
Dim dataFile As Document ' this data doc or template
Dim baseFile As Document ' file being modified
Dim baseFileFN As String ' path\name of file from Adobe
Dim rgData As Range ' range of data file containing replacements
Dim para As Paragraph ' paragraph in rgData
Dim rgPattern As Range ' a range used in baseFile
Dim replaceText As String ' current line from this data file
Dim iterNum As Long ' number of current line / saved file
Dim saveFN As String ' path\base name of saved file

Set dataFile = ActiveDocument

MsgBox "Select the data file (*.prtl) to be processed."
With Dialogs(wdDialogFileOpen)
.Name = "*.prtl"
If .Show = -1 Then
Set baseFile = ActiveDocument ' file just opened becomes Active
baseFileFN = baseFile.FullName ' this path\name will be used to open it again
Else
Exit Sub
End If
End With

MsgBox "Select the folder and filename (without numbers) to save as."
With Dialogs(wdDialogFileSaveAs)
If .Display = -1 Then ' just get the path\name, don't actually save
saveFN = WordBasic.FileNameInfo(.Name, 5) & WordBasic.FileNameInfo(.Name, 4) & "-"
'MsgBox saveFN
Else
Exit Sub
End If
End With

On Error GoTo Errhdl
iterNum = 1
Set rgData = dataFile.Range
rgData.MoveStart unit:=wdParagraph, Count:=1 ' exclude paragraph containing macro button
For Each para In rgData.Paragraphs
replaceText = Left(para.Range.Text, Len(para.Range.Text) - 1) ' exclude paragraph mark

' force all-caps XYZ to lower-case xyz
' to avoid inserting text from data file in all caps
Set rgPattern = baseFile.Range
With rgPattern.Find
.Text = "XYZ"
.Wrap = wdFindStop
While .Execute
rgPattern.Text = LCase(rgPattern.Text)
Wend
End With

' do the replacement
baseFile.Range.Find.Execute _
FindText:="xyz", _
MatchCase:=False, _
ReplaceWith:=replaceText, _
Replace:=wdReplaceAll

baseFile.SaveAs _
FileName:=saveFN & Format(iterNum, "0000") & ".prtl", _
FileFormat:=wdFormatText, _
AddToRecentFiles:=False

' close the modified file, then reopen the unmodified base
baseFile.Close SaveChanges:=wdDoNotSaveChanges
Set baseFile = Documents.Open(FileName:=baseFileFN, AddToRecentFiles:=False, Visible:=False)

iterNum = iterNum + 1
Next para

baseFile.Close SaveChanges:=wdDoNotSaveChanges
MsgBox "Done"
Exit Sub

Errhdl:
MsgBox "Error " & Err.Number & " at line " & iterNum & vbCr & Err.Description
End Sub

Thanks to Jay Freedman